Changeset 26396 in project


Ignore:
Timestamp:
04/07/12 14:44:36 (9 years ago)
Author:
sjamaan
Message:

numbers: Check that lcm and gcd correctly get integer values, even in flonum case

Location:
release/4/numbers/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/numbers/trunk/numbers.scm

    r26384 r26396  
    130130
    131131(define-inline (%flonum? x) (##core#inline "flonump" x))
    132 (define-inline (%flo-integer? x) (##core#inline "C_i_integerp" x))
     132(define-inline (%flo-integer? x) (##core#inline "C_u_i_fpintegerp" x))
    133133
    134134(define-inline (complex-real c) (##sys#slot c 1))
     
    287287    [RAT
    288288     (switchq (%check-number y)
    289        [RAT (rat+/- x y %+)]
     289       [RAT (rat+/- '+ %+ x y)]
    290290       [COMP (%comp+comp (%make-complex x 0) y)]
    291291       [NONE (bad-number '+ y)]
     
    358358    [RAT
    359359     (switchq (%check-number y)
    360        [RAT (rat+/- x y %-)]
     360       [RAT (rat+/- '- %- x y)]
    361361       [COMP (%comp-comp (%make-complex x 0) y)]
    362362       [NONE (bad-number '- y)]
     
    397397  ;; With   g = gcd(a, d)   and  a = x   [Knuth, 4.5.1]
    398398  (let* ((d (rat-denominator y))
    399          (g (%gcd-0 x d)))
     399         (g (%gcd-0 '* x d)))
    400400    (ratnum (%* (%quotient x g) (rat-numerator y))
    401401            (%quotient d g))))
     
    435435       [RAT (let* ((a (rat-numerator x)) (b (rat-denominator x))
    436436                   (c (rat-numerator y)) (d (rat-denominator y))
    437                    (g1 (%gcd-0 a d)) (g2 (%gcd-0 b c)))
     437                   (g1 (%gcd-0 '* a d)) (g2 (%gcd-0 '* b c)))
    438438              (ratnum (%* (%quotient a g1) (%quotient c g2))
    439439                      (%* (%quotient b g2) (%quotient d g1))))]
     
    472472  ;; With   g1 = gcd(a, c)   and   a = x  [Knuth, 4.5.1 ex. 4]
    473473  (let* ((c (rat-numerator y))
    474          (g (%gcd-0 x c)))
     474         (g (%gcd-0 '/ x c)))
    475475    (%/ (%* (%quotient x g) (rat-denominator y))
    476476        (%quotient c g))))
     
    483483              (ratnum (fx/ x g) (fx/ y g)))]
    484484       [FLO (fp/ (%fix->flo x) y)]
    485        [BIG (let ((g (%gcd-0 x y)))
     485       [BIG (let ((g (%gcd-0 '/ x y)))
    486486              (ratnum (%quotient x g) (%quotient y g)))]
    487487       [RAT (%nonrat/rat x y)]
     
    499499    [BIG
    500500     (switchq (%check-number y)
    501        [FIX (let ((g (%gcd-0 x (fix-div/0 x y '/))))
     501       [FIX (let ((g (%gcd-0 '/ x (fix-div/0 x y '/))))
    502502              (ratnum (%quotient x g) (%quotient y g)))]
    503503       [FLO (fp/ (%big->flo x) y)]
    504        [BIG (let ((g (%gcd-0 x y)))
     504       [BIG (let ((g (%gcd-0 '/ x y)))
    505505              (ratnum (%quotient x g) (%quotient y g)))]
    506506       [RAT (%nonrat/rat x y)]
     
    514514       [RAT (let* ((a (rat-numerator x)) (b (rat-denominator x))
    515515                   (c (rat-numerator y)) (d (rat-denominator y))
    516                    (g1 (%gcd-0 a c)) (g2 (%gcd-0 b d)))
     516                   (g1 (%gcd-0 '/ a c)) (g2 (%gcd-0 '/ b d)))
    517517              (%/ (%* (%quotient a g1) (%quotient d g2))
    518518                  (%* (%quotient b g2) (%quotient c g1))))]
     
    525525       ;; With   g = gcd(a, c)   and  c = y  [Knuth, 4.5.1 ex. 4]
    526526       [else (let* ((a (rat-numerator x))
    527                     (g (%gcd-0 a y))) ;; TODO: Improve error message if /0
     527                    (g (%gcd-0 '/ a y))) ;; TODO: Improve error message if /0
    528528               (%/ (%quotient a g)
    529529                   (%* (rat-denominator x) (%quotient y g))))] ) ]
     
    869869
    870870;; Knuth, 4.5.1
    871 (define (rat+/- x y op)
     871(define (rat+/- loc op x y)
    872872  (let ((a (rat-numerator x)) (b (rat-denominator x))
    873873        (c (rat-numerator y)) (d (rat-denominator y)))
    874     (let ((g1 (%gcd-0 b d)))
     874    (let ((g1 (%gcd-0 loc b d)))
    875875      (cond
    876876       ((eq? g1 1) (%make-rat (op (%* a d) (%* b c)) (%* b d)))
     
    879879       ;; TODO: Check properties of the gcd to see if g2 and t are needed
    880880       ((%= g1 b) (let* ((t (op (%* a (%quotient d g1)) c))
    881                          (g2 (%gcd-0 t g1)))
     881                         (g2 (%gcd-0 loc t g1)))
    882882                    (ratnum (%quotient t g2) (%quotient d g2))))
    883883       ((%= g1 d) (let* ((b/g1 (%quotient b g1))
    884884                         (t (op a (%* c b/g1))) ;; Is this worth it?
    885                          (g2 (%gcd-0 t g1)))
     885                         (g2 (%gcd-0 loc t g1)))
    886886                    (ratnum (%quotient t g2)
    887887                            (%* b/g1 (%quotient d g2)))))
     
    889889                    (t (op (%* a (%quotient d g1))
    890890                           (%* c b/g1)))
    891                     (g2 (%gcd-0 t g1)))
     891                    (g2 (%gcd-0 loc t g1)))
    892892               (%make-rat (%quotient t g2)
    893893                          (%* b/g1 (%quotient d g2)))))))))
     
    12331233(define ##sys#exact->inexact %exact->inexact)
    12341234
    1235 (define (%gcd-0 x y)
     1235(define (%gcd-0 loc x y)
    12361236  (switchq (%check-number x)
    12371237    [FIX (switchq (%check-number y)
     
    12391239           [FLO (if (%flo-integer? y)
    12401240                    (fpgcd (%fix->flo x) y)
    1241                     (bad-integer 'gcd y))]
     1241                    (bad-integer loc y))]
    12421242           [BIG (if (eq? x 0) y (fxgcd x (%remainder y x)))]
    1243            [else (bad-integer 'gcd y)])]
     1243           [else (bad-integer loc y)])]
    12441244    [FLO (switchq (%check-number y)
    12451245           [FIX (if (%flo-integer? x)
    12461246                    (fpgcd x (%fix->flo y))
    1247                     (bad-integer 'gcd x))]
     1247                    (bad-integer loc x))]
    12481248           [FLO (if (%flo-integer? x)
    12491249                    (if (%flo-integer? y)
    12501250                        (fpgcd x (%fix->flo y))
    1251                         (bad-integer 'gcd x))
    1252                     (bad-integer 'gcd x))]
     1251                        (bad-integer loc x))
     1252                    (bad-integer loc x))]
    12531253           [BIG (if (fp= x 0.0) y (fpgcd x (%remainder y x)))]
    1254            [else (bad-integer 'gcd y)])]
     1254           [else (bad-integer loc y)])]
    12551255    [BIG (switchq (%check-number y)
    12561256           [FIX (if (eq? y 0) x (fxgcd y (%remainder x y)))]
    12571257           [FLO (if (fp= y 0.0) x (fpgcd y (%remainder x y)))]
    12581258           [BIG (biggcd x y)]
    1259            [else (bad-integer 'gcd y)])]
    1260     [else (bad-integer 'gcd x)]) )
     1259           [else (bad-integer loc y)])]
     1260    [else (bad-integer loc x)]) )
    12611261
    12621262(define (gcd . ns)
     
    12671267              [next (##sys#slot ns 1)] )
    12681268          (if (null? next)
    1269               (%abs head)
     1269              (if f (%abs (%->integer 'gcd head)) (%abs head))
    12701270              (let ([n2 (##sys#slot next 0)])
    1271                 (loop (cons (%gcd-0 head n2) (##sys#slot next 1)) #f) ) ) ) ) ) )
    1272 
    1273 (define (%lcm-0 x y)
    1274   (%quotient (%* x y) (%gcd-0 x y)) )
     1271                (loop (cons (%gcd-0 'gcd head n2) (##sys#slot next 1)) #f) ) ) ) ) ) )
     1272
     1273(define (%lcm-0 loc x y)
     1274  (%quotient (%* x y) (%gcd-0 loc x y)) )
    12751275
    12761276(define (lcm . ns)
     
    12811281              [next (##sys#slot ns 1)] )
    12821282          (if (null? next)
    1283               (%abs head)
     1283              (if f (%abs (%->integer 'lcm head)) (%abs head))
    12841284              (let ([n2 (##sys#slot next 0)])
    1285                 (loop (cons (%lcm-0 head (##sys#slot next 0)) (##sys#slot next 1)) #f) ) ) ) ) ) )
     1285                (loop (cons (%lcm-0 'lcm head (##sys#slot next 0)) (##sys#slot next 1)) #f) ) ) ) ) ) )
    12861286
    12871287(define (%floor x)
  • release/4/numbers/trunk/tests/numbers-test.scm

    r26384 r26396  
    259259(test-group "gcd"
    260260  (test "gcd: fix (64-bit)/big" 1 (gcd 907947775416515 11111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111))
    261 )
     261  (test 0 (gcd))
     262  (test 6 (gcd 6))
     263  (test 2 (gcd 6 8))
     264  (test 1 (gcd 6 8 5))
     265  (test 1 (gcd 6 -8 5))
     266  (test 2.0 (gcd 6.0 8.0))
     267  (test-error (gcd 6.1 8.0))
     268  (test-error (gcd 6.0 8.1))
     269  (test-error (gcd +inf.0))
     270  (test-error (gcd +nan.0))
     271  (test-error (gcd 6.0 +inf.0))
     272  (test-error (gcd +inf.0 6.0))
     273  (test-error (gcd +nan.0 6.0))
     274  (test-error (gcd 6.0 +nan.0))
     275  (test-error (gcd 1+2i 3+4i))
     276  (test-error (gcd 1/2 3/4)))
     277
     278(test-group "lcm"
     279  (test 1 (lcm))
     280  (test 24 (lcm 6 8))
     281  (test 120 (lcm 6 8 5))
     282  (test 24.0 (lcm 6.0 8.0))
     283  (test-error (lcm 6.1 8.0))
     284  (test-error (lcm 6.0 8.1))
     285  (test-error (lcm +inf.0))
     286  (test-error (lcm +nan.0))
     287  (test-error (lcm 6.0 +inf.0))
     288  (test-error (lcm +inf.0 6.0))
     289  (test-error (lcm +nan.0 6.0))
     290  (test-error (lcm 6.0 +nan.0))
     291  (test-error (lcm 1+2i 3+4i))
     292  (test-error (lcm 1/2 3/4)))
    262293
    263294
     
    684715 (test "remainder" -1.0 (remainder -13 -4.0))
    685716
     717 (test-assert (even? 2))
     718 (test-assert (not (even? 1)))
     719 (test-assert (even? -2))
     720 (test-assert (not (even? -1)))
     721 (test-assert (even? 2.0))
     722 (test-assert (not (even? 1.0)))
     723 (test-assert (even? -2.0))
     724 (test-assert (not (even? -1.0)))
     725 (test-error (even? 2.1))
     726 (test-error (even? -2.3))
     727 (test-error (even? +inf.0))
     728 (test-error (even? +nan.0))
     729 (test-assert (even? (* most-positive-fixnum 2)))
     730 (test-assert (not (even? (+ (* most-positive-fixnum 2) 1))))
     731 (test-assert (odd? (+ (* most-positive-fixnum 2) 1)))
     732 (test-assert (not (odd? (* most-positive-fixnum 2))))
     733 (test-error (even? 2.0+3.0i))
     734 (test-error (even? 2+3i))
     735 (test-error (odd? 2.0+3.0i))
     736 (test-error (odd? 2+3i))
     737
    686738 (test "floor" -5.0 (floor -4.3))
    687739 (test "ceiling" -4.0 (ceiling -4.3))
     
    707759 (test-assert "not" (show (bitwise-not #x0f)))
    708760 (test "shift left" #x3c (arithmetic-shift #xf 2))
    709  (test "shift right" 60 (arithmetic-shift #xf 2))
     761 (test "shift right" #x3 (arithmetic-shift #xf -2))
    710762
    711763 ;; by Jeremy Sydik
Note: See TracChangeset for help on using the changeset viewer.