From 0483294762c8daf8f1637aec9c9544044bf2d357 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 25 Apr 2008 17:18:44 +0000 Subject: [PATCH] fix JIT abs (on least fixnum), fix some R6RS bugs and pull in some R6RS test cases from Ikarus svn: r9477 --- collects/drscheme/syncheck.ss | 2 +- collects/rnrs/arithmetic/fixnums-6.ss | 20 +- collects/rnrs/arithmetic/flonums-6.ss | 16 +- collects/rnrs/base-6.ss | 53 ++--- collects/rnrs/bytevectors-6.ss | 2 +- collects/tests/mzscheme/optimize.ss | 6 +- collects/tests/r6rs/arithmetic/bitwise.ss | 228 +++++++++++++++++++++- collects/tests/r6rs/arithmetic/fixnums.ss | 37 ++++ collects/tests/r6rs/base.ss | 194 ++++++++++++++++++ collects/tests/r6rs/bytevectors.ss | 192 +++++++++++++++++- collects/tests/r6rs/lists.ss | 42 ++++ collects/tests/r6rs/r5rs.ss | 102 ++++++++++ collects/tests/r6rs/run.ss | 2 + src/mzscheme/src/jit.c | 4 +- 14 files changed, 859 insertions(+), 41 deletions(-) diff --git a/collects/drscheme/syncheck.ss b/collects/drscheme/syncheck.ss index 9680cd14d7..4f31f8f8fb 100644 --- a/collects/drscheme/syncheck.ss +++ b/collects/drscheme/syncheck.ss @@ -1440,7 +1440,7 @@ If the namespace does not, they are colored the unbound color. (when (eq? nominal-source-id jump-to-id) (jump-to id)))))) (syntax->list vars))))]) - + (let level-loop ([sexp sexp] [high-level? #f]) diff --git a/collects/rnrs/arithmetic/fixnums-6.ss b/collects/rnrs/arithmetic/fixnums-6.ss index 3127a56120..129352d389 100644 --- a/collects/rnrs/arithmetic/fixnums-6.ss +++ b/collects/rnrs/arithmetic/fixnums-6.ss @@ -55,10 +55,22 @@ (define-fx * fx* (a b) check) (define-fx - fx- [(a) (a b)] check) -(define-fx div-and-mod fxdiv-and-mod (a b) nocheck) +(provide fxdiv-and-mod + fxdiv0-and-mod0) +(define (fxdiv-and-mod a b) + (unless (fixnum? a) + (raise-type-error 'fxdiv-and-mod "fixnum" a)) + (unless (fixnum? b) + (raise-type-error 'fxdiv-and-mod "fixnum" b)) + (div-and-mod a b)) (define-fx div fxdiv (a b) nocheck) (define-fx mod fxmod (a b) nocheck) -(define-fx div0-and-mod0 fxdiv0-and-mod0 (a b) nocheck) +(define (fxdiv0-and-mod0 a b) + (unless (fixnum? a) + (raise-type-error 'fxdiv0-and-mod0 "fixnum" a)) + (unless (fixnum? b) + (raise-type-error 'fxdiv0-and-mod0 "fixnum" b)) + (div0-and-mod0 a b)) (define-fx div0 fxdiv0 (a b) nocheck) (define-fx mod0 fxmod0 (a b) nocheck) @@ -72,13 +84,13 @@ (raise-type-error 'fx/carry "fixnum" b)) (unless (fixnum? a) (raise-type-error 'fx/carry "fixnum" b)) - (let-values ([(d m) (div0-and-mod0 (+ a b c) + (let-values ([(d m) (div0-and-mod0 expr (arithmetic-shift 1 (fixnum-width)))]) (values m d))))) (define-carry fx+/carry (a b c) (+ a b c)) (define-carry fx-/carry (a b c) (- a b c)) -(define-carry fx*/carry (a b c) (* (+ a b) c)) +(define-carry fx*/carry (a b c) (+ (* a b) c)) (define-fx bitwise-not fxnot (a) nocheck) (define-fx bitwise-and fxand (a b ...) nocheck) diff --git a/collects/rnrs/arithmetic/flonums-6.ss b/collects/rnrs/arithmetic/flonums-6.ss index 6024a80c08..2e6863ce03 100644 --- a/collects/rnrs/arithmetic/flonums-6.ss +++ b/collects/rnrs/arithmetic/flonums-6.ss @@ -49,10 +49,22 @@ (define-fl abs flabs (a) nocheck) -(define-fl div-and-mod fldiv-and-mod (a b) nocheck) +(provide fldiv-and-mod + fldiv0-and-mod0) +(define (fldiv-and-mod a b) + (unless (inexact-real? a) + (raise-type-error 'fldiv-and-mod "flonum" a)) + (unless (inexact-real? b) + (raise-type-error 'fldiv-and-mod "flonum" b)) + (div-and-mod a b)) (define-fl div fldiv (a b) nocheck) (define-fl mod flmod (a b) nocheck) -(define-fl div0-and-mod0 fldiv0-and-mod0 (a b) nocheck) +(define (fldiv0-and-mod0 a b) + (unless (inexact-real? a) + (raise-type-error 'fldiv0-and-mod0 "flonum" a)) + (unless (inexact-real? b) + (raise-type-error 'fldiv0-and-mod0 "flonum" b)) + (div0-and-mod0 a b)) (define-fl div0 fldiv0 (a b) nocheck) (define-fl mod0 flmod0 (a b) nocheck) diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss index 0dce0e393e..a45ed94954 100644 --- a/collects/rnrs/base-6.ss +++ b/collects/rnrs/base-6.ss @@ -210,30 +210,22 @@ ;; until the results matched the examples in R6RS. (define (div x y) - (let ([n (* (numerator x) - (denominator y))] - [d (* (denominator x) - (numerator y))]) - (if (negative? n) - (- (quotient (- (abs d) n 1) d)) - (quotient n d)))) - -(define (div0 x y) (cond - [(zero? y) 0] - [(positive? y) - (if (negative? x) - (- (div (- x) y)) - (div x y))] - [(negative? y) - (let ([n (* -2 - (numerator x) + [(rational? y) + (let ([n (* (numerator x) (denominator y))] [d (* (denominator x) - (- (numerator y)))]) - (if (< n d) - (- (quotient (- d n) (* 2 d))) - (quotient (+ n d -1) (* 2 d))))])) + (numerator y))]) + (if (negative? n) + (- (quotient (- (abs d) n 1) d)) + (quotient n d)))] + [(real? y) + ;; infinity or nan + (if (equal? y +nan.0) + +nan.0 + 1.0)] + [else + (raise-type-error "real number" y)])) (define (mod x y) (- x (* (div x y) y))) @@ -242,12 +234,21 @@ (let ([d (div x y)]) (values d (- x (* d y))))) -(define (mod0 x y) - (- x (* (div0 x y) y))) - (define (div0-and-mod0 x y) - (let ([d (div0 x y)]) - (values d (- x (* d y))))) + (let-values ([(d m) (div-and-mod x y)]) + (if (>= m (/ (abs y) 2)) + (if (negative? y) + (values (sub1 d) (+ m y)) + (values (add1 d) (- m y))) + (values d m)))) + +(define (div0 x y) + (let-values ([(d m) (div0-and-mod0 x y)]) + d)) + +(define (mod0 x y) + (let-values ([(d m) (div0-and-mod0 x y)]) + m)) (define-syntax r6rs:/ ;; R6RS says that division with exact zero is treated like diff --git a/collects/rnrs/bytevectors-6.ss b/collects/rnrs/bytevectors-6.ss index 8f53ce5688..9f9a6ccc70 100644 --- a/collects/rnrs/bytevectors-6.ss +++ b/collects/rnrs/bytevectors-6.ss @@ -281,7 +281,7 @@ (let ([pos-n (if (negative? n) (+ n (arithmetic-shift 1 (* 8 size))) n)]) - (bytevector-int-set! 'bytevector-uint-set! bstr k pos-n n endianness size (* size (sub1 8))))) + (bytevector-int-set! 'bytevector-sint-set! bstr k pos-n n endianness size (sub1 (* size 8))))) (define (bytevector->int-list who ref bv endianness size) (unless (bytes? bv) diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss index a7f394d7eb..def53e2e67 100644 --- a/collects/tests/mzscheme/optimize.ss +++ b/collects/tests/mzscheme/optimize.ss @@ -230,8 +230,10 @@ (un 0 'abs 0) (un 1 'abs 1) (un 1 'abs -1) - (un (sub1 (expt 2 31)) 'abs (sub1 (expt 2 31))) - (un (sub1 (expt 2 31)) 'abs (add1 (expt -2 31))) + (un (sub1 (expt 2 30)) 'abs (sub1 (expt 2 30))) + (un (expt 2 30) 'abs (- (expt 2 30))) + (un (sub1 (expt 2 62)) 'abs (sub1 (expt 2 62))) + (un (expt 2 62) 'abs (- (expt 2 62))) (bin 11 '+ 4 7) (bin -3 '+ 4 -7) diff --git a/collects/tests/r6rs/arithmetic/bitwise.ss b/collects/tests/r6rs/arithmetic/bitwise.ss index 28f2f32bea..d086bc83ac 100644 --- a/collects/tests/r6rs/arithmetic/bitwise.ss +++ b/collects/tests/r6rs/arithmetic/bitwise.ss @@ -5,6 +5,33 @@ (import (rnrs) (tests r6rs test)) + ;; Helpers originally from Ikarus test suite: + (define (ref ei) + (do ((result 0 (+ result 1)) + (bits (if (negative? ei) + (bitwise-not ei) + ei) + (bitwise-arithmetic-shift bits -1))) + ((zero? bits) + result))) + (define-syntax len-test + (syntax-rules () + [(_ n) (test (bitwise-length n) + (ref n))])) + (define (pos-count-bits n) + (if (zero? n) + 0 + (let ([c (count-bits (bitwise-arithmetic-shift-right n 1))]) + (if (even? n) c (+ c 1))))) + (define (count-bits n) + (if (>= n 0) + (pos-count-bits n) + (bitwise-not (pos-count-bits (bitwise-not n))))) + (define-syntax count-test + (syntax-rules () + [(_ n) + (test (bitwise-bit-count n) (count-bits n))])) + (define (run-arithmetic-bitwise-tests) (test (bitwise-first-bit-set 0) -1) @@ -19,7 +46,206 @@ (test (bitwise-arithmetic-shift -1 -1) -1) (test (bitwise-reverse-bit-field #b1010010 1 4) 88) ; #b1011000 - + + ;; Originally from Ikarus test suite: + (len-test #xF) + (len-test #xFF) + (len-test #xFFF) + (len-test #xFFFF) + (len-test #xFFFFF) + (len-test #xFFFFFF) + (len-test #xFFFFFFF) + (len-test #xFFFFFFFF) + (len-test #xFFFFFFFFF) + (len-test #xFFFFFFFFFF) + (len-test #xFFFFFFFFFFF) + (len-test #xFFFFFFFFFFFF) + (len-test #xFFFFFFFFFFFFF) + (len-test #xFFFFFFFFFFFFFF) + (len-test #xFFFFFFFFFFFFFFF) + (len-test #xFFFFFFFFFFFFFFFF) + (len-test #x-F) + (len-test #x-FF) + (len-test #x-FFF) + (len-test #x-FFFF) + (len-test #x-FFFFF) + (len-test #x-FFFFFF) + (len-test #x-FFFFFFF) + (len-test #x-FFFFFFFF) + (len-test #x-FFFFFFFFF) + (len-test #x-FFFFFFFFFF) + (len-test #x-FFFFFFFFFFF) + (len-test #x-FFFFFFFFFFFF) + (len-test #x-FFFFFFFFFFFFF) + (len-test #x-FFFFFFFFFFFFFF) + (len-test #x-FFFFFFFFFFFFFFF) + (len-test #x-FFFFFFFFFFFFFFFF) + + (len-test #xE) + (len-test #xFE) + (len-test #xFFE) + (len-test #xFFFE) + (len-test #xFFFFE) + (len-test #xFFFFFE) + (len-test #xFFFFFFE) + (len-test #xFFFFFFFE) + (len-test #xFFFFFFFFE) + (len-test #xFFFFFFFFFE) + (len-test #xFFFFFFFFFFE) + (len-test #xFFFFFFFFFFFE) + (len-test #xFFFFFFFFFFFFE) + (len-test #xFFFFFFFFFFFFFE) + (len-test #xFFFFFFFFFFFFFFE) + (len-test #xFFFFFFFFFFFFFFFE) + (len-test #x-E) + (len-test #x-FE) + (len-test #x-FFE) + (len-test #x-FFFE) + (len-test #x-FFFFE) + (len-test #x-FFFFFE) + (len-test #x-FFFFFFE) + (len-test #x-FFFFFFFE) + (len-test #x-FFFFFFFFE) + (len-test #x-FFFFFFFFFE) + (len-test #x-FFFFFFFFFFE) + (len-test #x-FFFFFFFFFFFE) + (len-test #x-FFFFFFFFFFFFE) + (len-test #x-FFFFFFFFFFFFFE) + (len-test #x-FFFFFFFFFFFFFFE) + (len-test #x-FFFFFFFFFFFFFFFE) + + (len-test #x1) + (len-test #x1F) + (len-test #x1FF) + (len-test #x1FFF) + (len-test #x1FFFF) + (len-test #x1FFFFF) + (len-test #x1FFFFFF) + (len-test #x1FFFFFFF) + (len-test #x1FFFFFFFF) + (len-test #x1FFFFFFFFF) + (len-test #x1FFFFFFFFFF) + (len-test #x1FFFFFFFFFFF) + (len-test #x1FFFFFFFFFFFF) + (len-test #x1FFFFFFFFFFFFF) + (len-test #x1FFFFFFFFFFFFFF) + (len-test #x1FFFFFFFFFFFFFFF) + (len-test #x-1) + (len-test #x-1F) + (len-test #x-1FF) + (len-test #x-1FFF) + (len-test #x-1FFFF) + (len-test #x-1FFFFF) + (len-test #x-1FFFFFF) + (len-test #x-1FFFFFFF) + (len-test #x-1FFFFFFFF) + (len-test #x-1FFFFFFFFF) + (len-test #x-1FFFFFFFFFF) + (len-test #x-1FFFFFFFFFFF) + (len-test #x-1FFFFFFFFFFFF) + (len-test #x-1FFFFFFFFFFFFF) + (len-test #x-1FFFFFFFFFFFFFF) + (len-test #x-1FFFFFFFFFFFFFFF) + + (len-test #x1) + (len-test #x10) + (len-test #x100) + (len-test #x1000) + (len-test #x10000) + (len-test #x100000) + (len-test #x1000000) + (len-test #x10000000) + (len-test #x100000000) + (len-test #x1000000000) + (len-test #x10000000000) + (len-test #x100000000000) + (len-test #x1000000000000) + (len-test #x10000000000000) + (len-test #x100000000000000) + (len-test #x1000000000000000) + (len-test #x-1) + (len-test #x-10) + (len-test #x-100) + (len-test #x-1000) + (len-test #x-10000) + (len-test #x-100000) + (len-test #x-1000000) + (len-test #x-10000000) + (len-test #x-100000000) + (len-test #x-1000000000) + (len-test #x-10000000000) + (len-test #x-100000000000) + (len-test #x-1000000000000) + (len-test #x-10000000000000) + (len-test #x-100000000000000) + (len-test #x-1000000000000000) + + (len-test #x1) + (len-test #x11) + (len-test #x101) + (len-test #x1001) + (len-test #x10001) + (len-test #x100001) + (len-test #x1000001) + (len-test #x10000001) + (len-test #x100000001) + (len-test #x1000000001) + (len-test #x10000000001) + (len-test #x100000000001) + (len-test #x1000000000001) + (len-test #x10000000000001) + (len-test #x100000000000001) + (len-test #x1000000000000001) + (len-test #x-1) + (len-test #x-11) + (len-test #x-101) + (len-test #x-1001) + (len-test #x-10001) + (len-test #x-100001) + (len-test #x-1000001) + (len-test #x-10000001) + (len-test #x-100000001) + (len-test #x-1000000001) + (len-test #x-10000000001) + (len-test #x-100000000001) + (len-test #x-1000000000001) + (len-test #x-10000000000001) + (len-test #x-100000000000001) + (len-test #x-1000000000000001) + + (len-test (greatest-fixnum)) + (len-test (least-fixnum)) + + (count-test 1) + (count-test 28472347823493290482390849023840928390482309480923840923840983) + (count-test -847234234903290482390849023840928390482309480923840923840983) + (count-test (greatest-fixnum)) + (count-test (least-fixnum)) + + (test (bitwise-not 12) -13) + (test (bitwise-not -12) 11) + (test (bitwise-not -1) 0) + (test (bitwise-not 0) -1) + (test (least-fixnum) (bitwise-not (greatest-fixnum))) + (test (greatest-fixnum) (bitwise-not (least-fixnum))) + + (test (bitwise-not 38947389478348937489374) + -38947389478348937489375) + (test (bitwise-not #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF) + -22300745198530623141535718272648361505980416) + (test (bitwise-not -38947389478348937489375) + 38947389478348937489374) + (test (bitwise-not #x-FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF) + 22300745198530623141535718272648361505980414) + (test (bitwise-not #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF) + -340282366920938463463374607431768211456) + (test (bitwise-not #x-FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF) + 340282366920938463463374607431768211454) + (test (bitwise-not #x1000000000000000000000000) + -79228162514264337593543950337) + (test (bitwise-not #x-1000000000000000000000000) + 79228162514264337593543950335) + ;; )) diff --git a/collects/tests/r6rs/arithmetic/fixnums.ss b/collects/tests/r6rs/arithmetic/fixnums.ss index 5ee90cd90f..2e58863d41 100644 --- a/collects/tests/r6rs/arithmetic/fixnums.ss +++ b/collects/tests/r6rs/arithmetic/fixnums.ss @@ -5,6 +5,40 @@ (import (rnrs) (tests r6rs test)) + ;; Originally from Ikarus test suite: + (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-syntax carry-test + (syntax-rules () + [(_ fxop/carry fxop/carry-reference fx1 fx2 fx3) + (test (call-with-values (lambda () (fxop/carry fx1 fx2 fx3)) list) + (call-with-values (lambda () (fxop/carry-reference fx1 fx2 fx3)) list))])) + + (define-syntax carry-tests + (syntax-rules () + [(_ 0 nums) + (carry-tests 0 nums nums nums)] + [(_ 0 (n ...) ms ps) + (begin (carry-tests 1 n ms ps) ...)] + [(_ 1 n (m ...) ps) + (begin (carry-tests 2 n m ps) ...)] + [(_ 2 n m (p ...)) + (begin (carry-test fx*/carry fx*/carry-reference n m p) ...)])) + (define (run-arithmetic-fixnums-tests) (test/exn (fx- (least-fixnum)) &implementation-restriction) @@ -144,6 +178,9 @@ (test (fx- (greatest-fixnum) (greatest-fixnum)) 0) (test (fx- (least-fixnum) (least-fixnum)) 0) + ;; If you put N numbers here, it expads to N^3 tests! + (carry-tests 0 [0 1 2 -1 -2 38734 -3843 2484598 -348732487 (greatest-fixnum) (least-fixnum)]) + ;; )) diff --git a/collects/tests/r6rs/base.ss b/collects/tests/r6rs/base.ss index 2ede41e86e..883f75e24e 100644 --- a/collects/tests/r6rs/base.ss +++ b/collects/tests/r6rs/base.ss @@ -35,6 +35,33 @@ (or (equal? v '(1 2)) (equal? v '(2 1)))) + ;; Based on tests from Ikarus: + (define-syntax divmod-test/? + (syntax-rules () + [(_ x1 x2) + (begin + (test/values (div-and-mod x1 x2) + (div x1 x2) + (mod x1 x2)) + (test/values (div0-and-mod0 x1 x2) + (div0 x1 x2) + (mod0 x1 x2)))])) + (define-syntax divmod-test + (syntax-rules () + [(_ x1 x2) + (begin + (divmod-test/? x1 x2) + (test (<= 0 (mod x1 x2)) #t) + (test (< (mod x1 x2) (abs x2)) #t) + (test (+ (* (div x1 x2) x2) (mod x1 x2)) x1) + (test (<= (- (abs (/ x2 2))) (mod0 x1 x2)) #t) + (test (< (mod0 x1 x2) (abs (/ x2 2))) #t) + (test (+ (* (div0 x1 x2) x2) (mod0 x1 x2)) x1))])) + + (define-syntax test-string-to-number + (syntax-rules () + [(_ [str num] ...) (begin (test (string->number str) num) ...)])) + ;; Definitions ---------------------------------------- (define add3 @@ -560,6 +587,126 @@ (test (div0 -123 -10) 12) (test (mod0 -123 -10) -3) + ;; `divmod-test' cases originally from Ikarus: + + (divmod-test +17 +3) + (divmod-test +17 -3) + (divmod-test -17 +3) + (divmod-test -17 -3) + (divmod-test +16 +3) + (divmod-test +16 -3) + (divmod-test -16 +3) + (divmod-test -16 -3) + (divmod-test +15 +3) + (divmod-test +15 -3) + (divmod-test -15 +3) + (divmod-test -15 -3) + (divmod-test +10 +4) + (divmod-test +10 -4) + (divmod-test -10 +4) + (divmod-test -10 -4) + + (divmod-test +3 +5/6) + (divmod-test -3 +5/6) + (divmod-test +3 -5/6) + (divmod-test -3 -5/6) + + (divmod-test +3 +7/11) + (divmod-test -3 +7/11) + (divmod-test +3 -7/11) + (divmod-test -3 -7/11) + + (divmod-test (least-fixnum) +1) + (divmod-test (least-fixnum) -1) + (divmod-test (greatest-fixnum) +1) + (divmod-test (greatest-fixnum) -1) + (divmod-test (least-fixnum) +2) + (divmod-test (least-fixnum) -2) + (divmod-test (greatest-fixnum) +2) + (divmod-test (greatest-fixnum) -2) + + (divmod-test 0 (least-fixnum)) + (divmod-test 0 (greatest-fixnum)) + (divmod-test +1 (least-fixnum)) + (divmod-test +1 (greatest-fixnum)) + (divmod-test -1 (least-fixnum)) + (divmod-test -1 (greatest-fixnum)) + (divmod-test +2 (least-fixnum)) + (divmod-test +2 (greatest-fixnum)) + (divmod-test -2 (least-fixnum)) + (divmod-test -2 (greatest-fixnum)) + + (divmod-test (least-fixnum) (least-fixnum)) + (divmod-test (greatest-fixnum) (least-fixnum)) + (divmod-test (least-fixnum) (greatest-fixnum)) + (divmod-test (greatest-fixnum) (greatest-fixnum)) + + (divmod-test +17.0 +3.0) + (divmod-test +17.0 -3.0) + (divmod-test -17.0 +3.0) + (divmod-test -17.0 -3.0) + (divmod-test +16.0 +3.0) + (divmod-test +16.0 -3.0) + (divmod-test -16.0 +3.0) + (divmod-test -16.0 -3.0) + (divmod-test +15.0 +3.0) + (divmod-test +15.0 -3.0) + (divmod-test -15.0 +3.0) + (divmod-test -15.0 -3.0) + (divmod-test +17.0 +3.5) + (divmod-test +17.0 -3.5) + (divmod-test -17.0 +3.5) + (divmod-test -17.0 -3.5) + (divmod-test +16.0 +3.5) + (divmod-test +16.0 -3.5) + (divmod-test -16.0 +3.5) + (divmod-test -16.0 -3.5) + (divmod-test +15.0 +3.5) + (divmod-test +15.0 -3.5) + (divmod-test -15.0 +3.5) + (divmod-test -15.0 -3.5) + (divmod-test/? +17.0 +nan.0) + (divmod-test/? -17.0 +nan.0) + (divmod-test/? +17.0 +inf.0) + (divmod-test/? +17.0 -inf.0) + (divmod-test/? -17.0 +inf.0) + (divmod-test/? -17.0 -inf.0) + + (divmod-test +17.0 +3.0) + (divmod-test +17.0 -3.0) + (divmod-test -17.0 +3.0) + (divmod-test -17.0 -3.0) + (divmod-test +16.0 +3.0) + (divmod-test +16.0 -3.0) + (divmod-test -16.0 +3.0) + (divmod-test -16.0 -3.0) + (divmod-test +15.0 +3.0) + (divmod-test +15.0 -3.0) + (divmod-test -15.0 +3.0) + (divmod-test -15.0 -3.0) + (divmod-test +17.0 +3.5) + (divmod-test +17.0 -3.5) + (divmod-test -17.0 +3.5) + (divmod-test -17.0 -3.5) + (divmod-test +16.0 +3.5) + (divmod-test +16.0 -3.5) + (divmod-test -16.0 +3.5) + (divmod-test -16.0 -3.5) + (divmod-test +15.0 +3.5) + (divmod-test +15.0 -3.5) + (divmod-test -15.0 +3.5) + (divmod-test -15.0 -3.5) + (divmod-test +10.0 +4.0) + (divmod-test +10.0 -4.0) + (divmod-test -10.0 +4.0) + (divmod-test -10.0 -4.0) + (divmod-test/? +17.0 +nan.0) + (divmod-test/? -17.0 +nan.0) + (divmod-test/? +17.0 +inf.0) + (divmod-test/? +17.0 -inf.0) + (divmod-test/? -17.0 +inf.0) + (divmod-test/? -17.0 -inf.0) + (test (gcd 32 -36) 4) (test (gcd) 0) (test (lcm 32 -36) 288) @@ -656,6 +803,53 @@ (test (string->number "-inf.0") -inf.0) (test (string->number "+nan.0") +nan.0) + ;; Originally from Ikarus: + (test-string-to-number + ("10" 10) + ("1" 1) + ("-17" -17) + ("+13476238746782364786237846872346782364876238477" + 13476238746782364786237846872346782364876238477) + ("1/2" (/ 1 2)) + ("-1/2" (/ 1 -2)) + ("#x24" 36) + ("#x-24" -36) + ("#b+00000110110" 54) + ("#b-00000110110/10" -27) + ("#e10" 10) + ("#e1" 1) + ("#e-17" -17) + ("#e#x24" 36) + ("#e#x-24" -36) + ("#e#b+00000110110" 54) + ("#e#b-00000110110/10" -27) + ("#x#e24" 36) + ("#x#e-24" -36) + ("#b#e+00000110110" 54) + ("#b#e-00000110110/10" -27) + ("#e1e1000" (expt 10 1000)) + ("#e-1e1000" (- (expt 10 1000))) + ("#e1e-1000" (expt 10 -1000)) + ("#e-1e-1000" (- (expt 10 -1000))) + ("#i1e100" (inexact (expt 10 100))) + ("#i1e1000" (inexact (expt 10 1000))) + ("#i-1e1000" (inexact (- (expt 10 1000)))) + ("1e100" (inexact (expt 10 100))) + ("1.0e100" (inexact (expt 10 100))) + ("1.e100" (inexact (expt 10 100))) + ("0.1e100" (inexact (expt 10 99))) + (".1e100" (inexact (expt 10 99))) + ("+1e100" (inexact (expt 10 100))) + ("+1.0e100" (inexact (expt 10 100))) + ("+1.e100" (inexact (expt 10 100))) + ("+0.1e100" (inexact (expt 10 99))) + ("+.1e100" (inexact (expt 10 99))) + ("-1e100" (inexact (- (expt 10 100)))) + ("-1.0e100" (inexact (- (expt 10 100)))) + ("-1.e100" (inexact (- (expt 10 100)))) + ("-0.1e100" (inexact (- (expt 10 99)))) + ("-.1e100" (inexact (- (expt 10 99))))) + ;; 11.8 (test (not #t) #f) (test (not 3) #f) diff --git a/collects/tests/r6rs/bytevectors.ss b/collects/tests/r6rs/bytevectors.ss index ed0be369e2..0b40b9f5c0 100644 --- a/collects/tests/r6rs/bytevectors.ss +++ b/collects/tests/r6rs/bytevectors.ss @@ -7,6 +7,9 @@ (define (run-bytevectors-tests) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Tests originally from R6RS + (test (let ((b (u8-list->bytevector '(1 2 3 4 5 6 7 8)))) (bytevector-copy! b 0 b 3 4) (bytevector->u8-list b)) @@ -101,9 +104,192 @@ (test (bytevector-s64-ref b 8 (endianness little)) -144115188075855873) (test (bytevector-u64-ref b 8 (endianness big)) 18446744073709551613) (test (bytevector-s64-ref b 8 (endianness big)) -3)) + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Tests originally from Ikarus + + (test (bytevector? (make-bytevector 1)) #t) + (test (bytevector? (make-bytevector 1 17)) #t) + (test (bytevector? (make-bytevector 10 -17)) #t) + (test (bytevector? 'foo) #f) + (test (bytevector? "hey") #f) + (test (bytevector? '#(2837 2398 239)) #f) + (test (bytevector-length (make-bytevector 0)) 0) + (test (bytevector-length (make-bytevector 100 -30)) 100) + (test (let ((b (u8-list->bytevector '(1 2 3 4 5 6 7 8)))) + (bytevector-copy! b 0 b 3 4) + (bytevector->u8-list b)) + '(1 2 3 1 2 3 4 8)) + (test (bytevector-uint-ref + (u8-list->bytevector '(17)) + 0 'little 1) + 17) + (test (bytevector-uint-ref + (u8-list->bytevector '(17)) + 0 'big 1) + 17) + (test (bytevector-uint-ref + (u8-list->bytevector '(17 54)) + 0 'little 2) + (+ 17 (* 54 256))) + (test (bytevector-uint-ref + (u8-list->bytevector (reverse '(17 54))) + 0 'big 2) + (+ 17 (* 54 256))) + (test (bytevector-uint-ref + (u8-list->bytevector '(17 54 98)) + 0 'little 3) + (+ 17 (* 54 256) (* 98 256 256))) + (test (bytevector-uint-ref + (u8-list->bytevector (reverse '(17 54 98))) + 0 'big 3) + (+ 17 (* 54 256) (* 98 256 256))) + (test (bytevector-uint-ref + (u8-list->bytevector '(17 54 98 120)) + 0 'little 4) + (+ 17 (* 54 256) (* 98 256 256) (* 120 256 256 256))) + + (test (bytevector-uint-ref + (u8-list->bytevector + '(#x89 #x04 #x39 #x82 #x49 #x20 #x93 #x48 #x17 + #x83 #x79 #x94 #x38 #x87 #x34 #x97 #x38 #x12)) + 0 'little 18) + #x123897348738947983174893204982390489) + (test (bytevector-uint-ref + (u8-list->bytevector + (reverse + '(#x89 #x04 #x39 #x82 #x49 #x20 #x93 #x48 #x17 + #x83 #x79 #x94 #x38 #x87 #x34 #x97 #x38 #x12))) + 0 'big 18) + #x123897348738947983174893204982390489) + (test (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2)))) + (bytevector->uint-list b 'little 2)) + '(513 65283 513 513)) + (test (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2)))) + (bytevector->sint-list b 'little 2)) + '(513 -253 513 513)) + (test (let ((b (make-bytevector 16 -127))) + (bytevector-uint-set! b 0 (- (expt 2 128) 3) 'little 16) + (list + (bytevector-uint-ref b 0 'little 16) + (bytevector-sint-ref b 0 'little 16) + (bytevector->u8-list b))) + '(#xfffffffffffffffffffffffffffffffd + -3 + (253 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 255))) + (test (let ((b (make-bytevector 16 -127))) + (bytevector-uint-set! b 0 (- (expt 2 128) 3) 'big 16) + (list + (bytevector-uint-ref b 0 'big 16) + (bytevector-sint-ref b 0 'big 16) + (bytevector->u8-list b))) + '(#xfffffffffffffffffffffffffffffffd + -3 + (255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253))) + (test (bytevector->u8-list '#vu8(1 2 3 4)) + '(1 2 3 4)) + (test (let ((b (make-bytevector 4 0))) + (bytevector-sint-set! b 0 -1 'little 4) + (bytevector-uint-ref b 0 'little 4)) + #xFFFFFFFF) + (test (let ((b (make-bytevector 4 0))) + (bytevector-sint-set! b 0 -256 'little 4) + (bytevector-uint-ref b 0 'little 4)) + #xFFFFFF00) + (test (let ((b (make-bytevector 4 0))) + (bytevector-sint-set! b 0 (- (expt 256 2)) 'little 4) + (bytevector-uint-ref b 0 'little 4)) + #xFFFF0000) + (test (let ((b (make-bytevector 8 0))) + (bytevector-sint-set! b 0 (- (expt 256 2)) 'little 8) + (bytevector-uint-ref b 0 'little 8)) + #xFFFFFFFFFFFF0000) + (test (let ((b (make-bytevector 8 0))) + (bytevector-sint-set! b 0 (- (expt 256 4)) 'little 8) + (bytevector-uint-ref b 0 'little 8)) + #xFFFFFFFF00000000) + (test (let ((b (make-bytevector 8 0))) + (bytevector-sint-set! b 0 (- (expt 256 7)) 'little 8) + (bytevector-uint-ref b 0 'little 8)) + #xFF00000000000000) + (test (let ((b (make-bytevector 8 0))) + (bytevector-sint-set! b 0 (- 1 (expt 2 63)) 'little 8) + (bytevector-sint-ref b 0 'little 8)) + (- 1 (expt 2 63))) + (test (let ((b (make-bytevector 4 38))) + (bytevector-sint-set! b 0 (- (expt 2 31) 1) 'little 4) + (bytevector-sint-ref b 0 'little 4)) + #x7FFFFFFF) + (test (let ((b (make-bytevector 4 38))) + (bytevector-sint-set! b 0 (- (expt 2 31)) 'little 4) + (bytevector-sint-ref b 0 'little 4)) + #x-80000000) + (test (let ((b (make-bytevector 5 38))) + (bytevector-sint-set! b 0 (- (expt 2 32)) 'little 5) + (bytevector-sint-ref b 0 'little 5)) + #x-100000000) + (test (let ((b (make-bytevector 4 0))) + (bytevector-sint-set! b 0 -1 'big 4) + (bytevector-uint-ref b 0 'big 4)) + #xFFFFFFFF) + (test (let ((b (make-bytevector 4 0))) + (bytevector-sint-set! b 0 -256 'big 4) + (bytevector-uint-ref b 0 'big 4)) + #xFFFFFF00) + (test (let ((b (make-bytevector 4 0))) + (bytevector-sint-set! b 0 (- (expt 256 2)) 'big 4) + (bytevector-uint-ref b 0 'big 4)) + #xFFFF0000) + (test (let ((b (make-bytevector 8 0))) + (bytevector-sint-set! b 0 (- (expt 256 2)) 'big 8) + (bytevector-uint-ref b 0 'big 8)) + #xFFFFFFFFFFFF0000) + (test (let ((b (make-bytevector 8 0))) + (bytevector-sint-set! b 0 (- (expt 256 4)) 'big 8) + (bytevector-uint-ref b 0 'big 8)) + #xFFFFFFFF00000000) + (test (let ((b (make-bytevector 8 0))) + (bytevector-sint-set! b 0 (- (expt 256 7)) 'big 8) + (bytevector-uint-ref b 0 'big 8)) + #xFF00000000000000) + (test (let ((b (make-bytevector 8 0))) + (bytevector-sint-set! b 0 (- 1 (expt 2 63)) 'big 8) + (bytevector-sint-ref b 0 'big 8)) + (- 1 (expt 2 63))) + (test (let ((b (make-bytevector 4 38))) + (bytevector-sint-set! b 0 (- (expt 2 31) 1) 'big 4) + (bytevector-sint-ref b 0 'big 4)) + #x7FFFFFFF) + (test (let ((b (make-bytevector 4 38))) + (bytevector-sint-set! b 0 (- (expt 2 31)) 'big 4) + (bytevector-sint-ref b 0 'big 4)) + #x-80000000) + (test (let ((b (make-bytevector 5 38))) + (bytevector-sint-set! b 0 (- (expt 2 32)) 'big 5) + (bytevector-sint-ref b 0 'big 5)) + #x-100000000) + (test (bytevector-u16-ref '#vu8(255 253) 0 'little) + 65023) + (test (bytevector-u16-ref '#vu8(255 253) 0 'big) + 65533) + (test (bytevector-s16-ref '#vu8(255 253) 0 'little) + -513) + (test (bytevector-s16-ref '#vu8(255 253) 0 'big) + -3) + (test (let ((v (make-bytevector 2))) + (bytevector-u16-native-set! v 0 12345) + (bytevector-u16-native-ref v 0)) + 12345) + (test (let ((v (make-bytevector 2))) + (bytevector-u16-set! v 0 12345 'little) + (bytevector-u16-ref v 0 'little)) + 12345) + (test (let ((v (make-bytevector 2))) + (bytevector-u16-set! v 0 12345 'big) + (bytevector-u16-ref v 0 'big)) + 12345) ;; )) - - - diff --git a/collects/tests/r6rs/lists.ss b/collects/tests/r6rs/lists.ss index 24a8b6f309..2eaf1300f8 100644 --- a/collects/tests/r6rs/lists.ss +++ b/collects/tests/r6rs/lists.ss @@ -6,6 +6,9 @@ (tests r6rs test)) (define (run-lists-tests) + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Tests originally from R6RS (test (find even? '(3 1 4 1 5 9)) 4) (test (find even? '(3 1 5 1 5 9)) #f) @@ -105,5 +108,44 @@ (test (cons* 1 2 3) '(1 2 . 3)) (test (cons* 1) 1) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Tests originally from Ikarus + + (test (for-all even? '(1 2 3 4)) #f) + (test (for-all even? '(10 12 14 16)) #t) + (test (for-all even? '(2 3 4)) #f) + (test (for-all even? '(12 14 16)) #t) + (test (for-all (lambda (x) x) '(12 14 16)) 16) + (test (for-all (lambda (x) x) '(12 14)) 14) + (test (for-all (lambda (x) x) '(12)) 12) + (test (for-all (lambda (x) x) '()) #t) + (test (for-all even? '(13 . 14)) #f) + (test (for-all cons '(1 2 3) '(a b c)) '(3 . c)) + (test (for-all (lambda (a b) (= a 1)) '(1 2 3) '(a b c)) #f) + (test (for-all (lambda (a b) (= a 1)) '(1 2) '(a b c)) #f) + (test (fold-left + 0 '(1 2 3 4 5)) 15) + (test (fold-left (lambda (a b) (cons b a)) '() '(1 2 3 4 5)) + '(5 4 3 2 1)) + (test (fold-left (lambda (count x) + (if (odd? x) + (+ count 1) + count)) + 0 + '(3 1 4 1 5 9 2 6 5 3)) + 7) + (test (fold-left cons '(q) '(a b c)) '((((q) . a) . b) . c)) + (test (fold-left + 0 '(1 2 3) '(4 5 6)) 21) + (test (fold-right + 0 '(1 2 3 4 5)) 15) + (test (fold-right cons '() '(1 2 3 4 5)) + '(1 2 3 4 5)) + (test (fold-right (lambda (x l) + (if (odd? x) + (cons x l) + l)) + '() + '(3 1 4 1 5 9 2 6 5 3)) + '(3 1 1 5 9 5 3)) + (test (fold-right + 0 '(1 2 3) '(4 5 6)) 21) + ;; )) diff --git a/collects/tests/r6rs/r5rs.ss b/collects/tests/r6rs/r5rs.ss index 28fe44e12b..d091bf6685 100644 --- a/collects/tests/r6rs/r5rs.ss +++ b/collects/tests/r6rs/r5rs.ss @@ -58,6 +58,108 @@ (test (begin (set! x 10) (force p)) 6) + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; quotient, remainder, and modulo tests from Ikarus's + ;; "bignums" test suite + + (test (quotient 348972 3434) + 101) + (test (quotient -348972 3434) + -101) + (test (quotient 348972 -3434) + -101) + (test (quotient -348972 -3434) + 101) + (test (quotient 536870912 238) + 2255760) + (test (quotient -536870912 238) + -2255760) + (test (quotient 536870912 -238) + -2255760) + (test (quotient -536870912 -238) + 2255760) + (test (quotient 536870912238479837489374 324873) + 1652556267336712615) + (test (quotient -536870912238479837489374 324873) + -1652556267336712615) + (test (quotient 536870912238479837489374 -324873) + -1652556267336712615) + (test (quotient -536870912238479837489374 -324873) + 1652556267336712615) + (test (quotient 536870912238479837489374 3248732398479823749283) + 165) + (test (quotient -536870912238479837489374 3248732398479823749283) + -165) + (test (quotient 536870912238479837489374 -3248732398479823749283) + -165) + (test (quotient -536870912238479837489374 -3248732398479823749283) + 165) + (test (quotient 5368709122384798374893743894798327498234 3248732398479823749283) + 1652555047284588078) + (test (quotient -5368709122384798374893743894798327498234 3248732398479823749283) + -1652555047284588078) + (test (quotient 5368709122384798374893743894798327498234 -3248732398479823749283) + -1652555047284588078) + (test (quotient -5368709122384798374893743894798327498234 -3248732398479823749283) + 1652555047284588078) + (test (remainder 23 349839489348) + 23) + (test (remainder -23 349839489348) + -23) + (test (remainder 23 -349839489348) + 23) + (test (remainder -23 -349839489348) + -23) + (test (modulo 348972 3434) + 2138) + (test (modulo -348972 3434) + 1296) + (test (modulo 348972 -3434) + -1296) + (test (modulo -348972 -3434) + -2138) + (test (modulo -23 349839489348) + 349839489325) + (test (modulo -23 -349839489348) + -23) + (test (modulo 23 349839489348) + 23) + (test (modulo 23 -349839489348) + -349839489325) + (test (remainder 536870912 238) + 32) + (test (remainder -536870912 238) + -32) + (test (remainder 536870912 -238) + 32) + (test (remainder -536870912 -238) + -32) + (test (modulo 536870912 238) + 32) + (test (modulo -536870912 238) + 206) + (test (modulo 536870912 -238) + -206) + (test (modulo -536870912 -238) + -32) + (test (modulo 536870912238479837489374 324873) + 116479) + (test (modulo -536870912238479837489374 324873) + 208394) + (test (modulo 536870912238479837489374 -324873) + -208394) + (test (modulo -536870912238479837489374 -324873) + -116479) + (test (modulo 536870912238479837489374 3248732398479823749283) + 830066489308918857679) + (test (modulo 536870912238479837489374 -3248732398479823749283) + -2418665909170904891604) + (test (modulo -536870912238479837489374 3248732398479823749283) + 2418665909170904891604) + (test (modulo -536870912238479837489374 -3248732398479823749283) + -830066489308918857679) + ;; )) diff --git a/collects/tests/r6rs/run.ss b/collects/tests/r6rs/run.ss index e6429c1dd8..4397449654 100644 --- a/collects/tests/r6rs/run.ss +++ b/collects/tests/r6rs/run.ss @@ -3,6 +3,7 @@ (import (rnrs) (tests r6rs test) (tests r6rs base) + (tests r6rs reader) (tests r6rs unicode) (tests r6rs bytevectors) (tests r6rs lists) @@ -27,6 +28,7 @@ (run-base-tests) +(run-reader-tests) (run-unicode-tests) (run-bytevectors-tests) (run-lists-tests) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index fa34478604..ead27402f1 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -3180,7 +3180,9 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj } else if (arith == 11) { /* abs */ jit_insn *refc; - refc = jit_bgti_l(jit_forward(), JIT_R0, (long)scheme_make_integer(0)); + refc = jit_bgei_l(jit_forward(), JIT_R0, (long)scheme_make_integer(0)); + /* watch out for most negative fixnum! */ + (void)jit_beqi_p(refslow, JIT_R0, (void *)((1 << ((8 * JIT_WORD_SIZE) - 1)) | 0x1)); jit_rshi_l(JIT_R0, JIT_R0, 1); jit_movi_l(JIT_R1, 0); jit_subr_l(JIT_R0, JIT_R1, JIT_R0);