/[guile]/guile/guile-core/test-suite/tests/numbers.test
ViewVC logotype

Diff of /guile/guile-core/test-suite/tests/numbers.test

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.35 by mvo, Fri Oct 10 14:32:11 2003 UTC revision 1.36 by kryde, Sun Oct 19 00:34:39 2003 UTC
# Line 15  Line 15 
15  ;;;; License along with this library; if not, write to the Free Software  ;;;; License along with this library; if not, write to the Free Software
16  ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA  ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17    
18  (use-modules (ice-9 documentation))  (define-module (test-suite test-numbers)
19      #:use-module (test-suite lib)
20      #:use-module (ice-9 documentation))
21    
22  ;;;  ;;;
23  ;;; miscellaneous  ;;; miscellaneous
# Line 33  Line 35 
35  (define fixnum-min most-negative-fixnum)  (define fixnum-min most-negative-fixnum)
36  (define fixnum-max most-positive-fixnum)  (define fixnum-max most-positive-fixnum)
37    
38    ;; Divine the number of bits in the mantissa of a flonum.
39    ;; We look for when 2.0^i+1.0 gets rounded, ie. the difference between that
40    ;; value and 2.0^k is not 1.0.
41    ;; Of course this assumes flonums have a fixed precision mantissa, but
42    ;; that's the case now and probably into the forseeable future.
43    ;; On an IEEE system, which means pretty much everywhere, the value here is
44    ;; the usual 53.
45    ;;
46    (define dbl-mant-dig
47      (let more ((i 1)
48                 (d 2.0))
49        (if (> i 1024)
50            (error "Oops, cannot determine number of bits in mantissa of inexact"))
51        (let* ((sum  (+ 1.0 d))
52               (diff (- sum d)))
53          (if (= diff 1.0)
54              (more (1+ i) (* 2.0 d))
55              i))))
56    
57    ;; like ash, but working on a flonum
58    (define (ash-flo x n)
59      (while (> n 0)
60        (set! x (* 2.0 x))
61        (set! n (1- n)))
62      (while (< n 0)
63        (set! x (* 0.5 x))
64        (set! n (1+ n)))
65      x)
66        
67    
68  ;;;  ;;;
69  ;;; exact?  ;;; exact?
70  ;;;  ;;;
# Line 1965  Line 1997 
1997  ;;; exact->inexact  ;;; exact->inexact
1998  ;;;  ;;;
1999    
2000    (with-test-prefix "exact->inexact"
2001      
2002      ;; Test "(exact->inexact n)", expect "want".
2003      ;; "i" is a index, for diagnostic purposes.
2004      (define (try-i i n want)
2005        (with-test-prefix (list i n want)
2006          (with-test-prefix "pos"
2007            (let ((got (exact->inexact n)))
2008              (pass-if "inexact?" (inexact? got))
2009              (pass-if (list "=" got) (= want got))))
2010          (set! n    (- n))
2011          (set! want (- want))
2012          (with-test-prefix "neg"
2013            (let ((got (exact->inexact n)))
2014              (pass-if "inexact?" (inexact? got))
2015              (pass-if (list "=" got) (= want got))))))
2016      
2017      (with-test-prefix "2^i, no round"
2018        (do ((i    0   (1+ i))
2019             (n    1   (* 2 n))
2020             (want 1.0 (* 2.0 want)))
2021            ((> i 100))
2022          (try-i i n want)))
2023      
2024      (with-test-prefix "2^i+1, no round"
2025        (do ((i    1   (1+ i))
2026             (n    3   (1- (* 2 n)))
2027             (want 3.0 (- (* 2.0 want) 1.0)))
2028            ((>= i dbl-mant-dig))
2029          (try-i i n want)))
2030      
2031      (with-test-prefix "(2^i+1)*2^100, no round"
2032        (do ((i    1   (1+ i))
2033             (n    3   (1- (* 2 n)))
2034             (want 3.0 (- (* 2.0 want) 1.0)))
2035            ((>= i dbl-mant-dig))
2036          (try-i i (ash n 100) (ash-flo want 100))))
2037      
2038      ;; bit pattern: 1111....11100.00
2039      ;;              <-mantdig-><-i->
2040      ;;
2041      (with-test-prefix "mantdig ones then zeros, no rounding"
2042        (do ((i    0  (1+ i))
2043             (n    (- (ash     1   dbl-mant-dig) 1)   (* 2 n))
2044             (want (- (ash-flo 1.0 dbl-mant-dig) 1.0) (* 2.0 want)))
2045            ((> i 100))
2046          (try-i i n want)))
2047      
2048      ;; bit pattern: 1111....111011..1
2049      ;;              <-mantdig-> <-i->
2050      ;; This sort of value was incorrectly rounded upwards in Guile 1.6.4 when
2051      ;; i >= 11 (that's when the total is 65 or more bits).
2052      ;;
2053      (with-test-prefix "mantdig ones then 011..11, round down"
2054        (do ((i    0  (1+ i))
2055             (n    (- (ash     1   (+ 1 dbl-mant-dig)) 2)   (+ 1 (* 2 n)))
2056             (want (- (ash-flo 1.0 (+ 1 dbl-mant-dig)) 2.0) (* 2.0 want)))
2057            ((> i 100))
2058          (try-i i n want)))
2059      
2060      ;; bit pattern: 1111....111100..001
2061      ;;              <-mantdig-> <--i->
2062      ;;
2063      (with-test-prefix "mantdig ones then 100..001, round up"
2064        (do ((i    0  (1+ i))
2065             (n    (- (ash     1   (+ 2 dbl-mant-dig)) 1)  (1- (* 2 n)))
2066             (want    (ash-flo 1.0 (+ 2 dbl-mant-dig))     (* 2.0 want)))
2067            ((> i 100))
2068          (try-i i n want)))
2069      
2070      ;; bit pattern: 1000....000100..001
2071      ;;              <-mantdig-> <--i->
2072      ;;
2073      (with-test-prefix "2^mantdig then 100..001, round up"
2074        (do ((i    0  (1+ i))
2075             (n    (- (ash     1   (+ 2 dbl-mant-dig)) 1)   (1- (* 2 n)))
2076             (want (+ (ash-flo 1.0 (+ 2 dbl-mant-dig)) 4.0) (* 2.0 want)))
2077            ((> i 100))
2078          (try-i i n want))))
2079    
2080  ;;;  ;;;
2081  ;;; floor  ;;; floor
2082  ;;;  ;;;

Legend:
Removed from v.1.35  
changed lines
  Added in v.1.36

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26