diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/number.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/number.rktl index f7a84fbe36..d295a3f453 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/number.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/number.rktl @@ -3077,6 +3077,59 @@ (test #t list? (filter n-digit-has-nth-root? (build-list 5000 (lambda (x) (+ x 1)))))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; exact->inexact precision (thanks to Neil Toronto) + +(require racket/extflonum) + +(define (check start end exact-> >=?) + (define delta (/ (- end start) 300)) + (for/fold ([prev (exact-> start)]) ([i (in-range start (+ end delta) delta)]) + (define next (exact-> i)) + (test #t >=? next prev) + next) + (for/fold ([prev (exact-> start)]) ([i (in-range start (+ end delta) delta)]) + (define next (exact-> (- i))) + (test #t >=? prev next) + next) + (void)) + +(check #e100000000000000.0 #e100000000000000.1 exact->inexact >=) +(check #e100000000000000.0 #e100000000000000.1 real->double-flonum >=) +(check #e1000000.0 #e1000000.1 real->single-flonum >=) +(when extflonum-available? + (check #e1000000000000000000.0 #e1000000000000000000.1 real->extfl extfl>=)) + +;; Sanity check +(test 0.14285714285714285 real->double-flonum 1/7) +(test 1.2857142857142858 real->double-flonum 9/7) +;; Cases that real->double-flonum used to get wrong +(test -4882.526517254422 real->double-flonum -13737024017780747/2813507303900) +(test -9.792844933246106e-14 real->double-flonum -1656/16910305547451097) + +;; Hack to use the "math" package when it's available: +(when (collection-file-path "base.rkt" "math" #:fail (lambda (x) #f)) + (eval + '(begin + (test #t string? "Randomized testing of rational->flonum") + + (require math/base + math/flonum) + + (define (random-rational) + (define d (random-bits (+ 1 (random 8192)))) + (cond [(zero? d) (random-rational)] + [else + (* (if (< (random) 0.5) -1 1) + (/ (random-bits (+ 1 (random 8192))) d))])) + + (for ([_ (in-range 10000)]) + (define ry (random-rational)) + (define y (real->double-flonum ry)) ; this generates rounding errors + (define e (flulp-error y ry)) + (unless (<= e 0.5) + (test #t (lambda (e y ry) (<= e 0.5)) e y ry)))))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/racket/src/racket/src/numarith.c b/racket/src/racket/src/numarith.c index 1082998fe5..459ee0b59a 100644 --- a/racket/src/racket/src/numarith.c +++ b/racket/src/racket/src/numarith.c @@ -1103,21 +1103,39 @@ scheme_modulo(int argc, Scheme_Object *argv[]) return rem_mod(argc, argv, "modulo", 0); } +static Scheme_Object * +do_quotient_remainder(const Scheme_Object *n1, const Scheme_Object *n2, Scheme_Object **_rem) +{ + Scheme_Object *rem = NULL, *quot, *a[2]; + + quot = do_bin_quotient("quotient/remainder", n1, n2, &rem); + if (!rem) { + a[0] = (Scheme_Object *)n1; + a[1] = (Scheme_Object *)n2; + rem = rem_mod(2, a, "remainder", 1); + } + *_rem = rem; + + return quot; +} Scheme_Object * quotient_remainder(int argc, Scheme_Object *argv[]) { - Scheme_Object *rem = NULL, *quot, *a[2]; + Scheme_Object *rem, *quot, *a[2]; - quot = do_bin_quotient("quotient/remainder", argv[0], argv[1], &rem); - if (!rem) { - rem = rem_mod(argc, argv, "remainder", 1); - } + quot = do_quotient_remainder(argv[0], argv[1], &rem); a[0] = quot; a[1] = rem; return scheme_values(2, a); } +Scheme_Object *scheme_bin_quotient_remainder(const Scheme_Object *n1, const Scheme_Object *n2, + Scheme_Object **_rem) +{ + return do_quotient_remainder(n1, n2, _rem); +} + /************************************************************************/ /* Flfx */ /************************************************************************/ diff --git a/racket/src/racket/src/ratfloat.inc b/racket/src/racket/src/ratfloat.inc index 5f427a4acf..611848c211 100644 --- a/racket/src/racket/src/ratfloat.inc +++ b/racket/src/racket/src/ratfloat.inc @@ -27,26 +27,48 @@ FP_TYPE SCHEME_RATIONAL_TO_FLOAT(const Scheme_Object *o) intptr_t ns, ds; if (SCHEME_INTP(r->num)) { - #ifdef CONVERT_INT_TO_FLOAT - n = CONVERT_INT_TO_FLOAT(SCHEME_INT_VAL(r->num)); - #else - n = FP_TYPE_FROM_INT(SCHEME_INT_VAL(r->num)); - #endif - ns = 0; - } else - n = SCHEME_BIGNUM_TO_FLOAT_INF_INFO(r->num, 0, &ns); + if (FIXNUM_FITS_FP(r->num)) { +#ifdef CONVERT_INT_TO_FLOAT + n = CONVERT_INT_TO_FLOAT(SCHEME_INT_VAL(r->num)); +#else + n = FP_TYPE_FROM_INT(SCHEME_INT_VAL(r->num)); +#endif + ns = 0; + } else { + n = FP_ZEROx; + ns = 1; + } + } else { + if (BIGNUM_FITS_FP(r->num)) { + n = SCHEME_BIGNUM_TO_FLOAT_INF_INFO(r->num, 0, &ns); + } else { + n = FP_ZEROx; + ns = 1; + } + } if (SCHEME_INTP(r->denom)) { - d = FP_TYPE_FROM_INT(SCHEME_INT_VAL(r->denom)); - ds = 0; - } else - d = SCHEME_BIGNUM_TO_FLOAT_INF_INFO(r->denom, 0, &ds); + if (FIXNUM_FITS_FP(r->denom)) { + d = FP_TYPE_FROM_INT(SCHEME_INT_VAL(r->denom)); + ds = 0; + } else { + d = FP_ZEROx; + ds = 1; + } + } else { + if (BIGNUM_FITS_FP(r->denom)) { + d = SCHEME_BIGNUM_TO_FLOAT_INF_INFO(r->denom, 0, &ds); + } else { + d = FP_ZEROx; + ds = 1; + } + } if (ns || ds) { /* Quick path doesn't necessarily work. The more general way is adpated from Gambit-C 4.1. */ intptr_t nl, dl, p, shift; - Scheme_Object *a[2], *n, *d; + Scheme_Object *a[2], *n, *d, *rem; FP_TYPE res; a[0] = r->num; @@ -87,10 +109,26 @@ FP_TYPE SCHEME_RATIONAL_TO_FLOAT(const Scheme_Object *o) a[1] = scheme_make_integer(shift); n = scheme_bitwise_shift(2, a); - n = scheme_bin_div(n, d); - if (SCHEME_RATIONALP(n)) - n = scheme_rational_round(n); - + /* Rounded divide: */ + n = scheme_bin_quotient_remainder(n, d, &rem); + a[0] = d; + a[1] = scheme_make_integer(-1); + d = scheme_bitwise_shift(2, a); + if (!scheme_bin_lt(rem, d)) { + if (scheme_bin_gt(rem, d)) { + n = scheme_bin_plus(n, scheme_make_integer(1)); + } else { + /* Round to even: */ + a[0] = d; + if (!scheme_odd_p(1, a)) { + a[0] = n; + if (!scheme_even_p(1, a)) { + n = scheme_bin_plus(n, scheme_make_integer(1)); + } + } + } + } + if (SCHEME_INTP(n)) res = FP_TYPE_FROM_INT(SCHEME_INT_VAL(n)); else @@ -178,6 +216,8 @@ Scheme_Object *SCHEME_RATIONAL_FROM_FLOAT(FP_TYPE d) #undef SCHEME_BIGNUM_TO_FLOAT_INF_INFO #undef SCHEME_BIGNUM_FROM_FLOAT #undef SCHEME_CHECK_FLOAT +#undef FIXNUM_FITS_FP +#undef BIGNUM_FITS_FP #undef DO_FLOAT_DIV #undef FLOAT_E_MIN #undef FLOAT_M_BITS diff --git a/racket/src/racket/src/rational.c b/racket/src/racket/src/rational.c index fbf8b5dc67..5002fff1fa 100644 --- a/racket/src/racket/src/rational.c +++ b/racket/src/racket/src/rational.c @@ -523,6 +523,13 @@ Scheme_Object *scheme_rational_sqrt(const Scheme_Object *o) #define FP_LESS(x, y) x