diff --git a/R6RS-TODO.txt b/R6RS-TODO.txt index 86032b0..c47fd9f 100644 --- a/R6RS-TODO.txt +++ b/R6RS-TODO.txt @@ -48,7 +48,7 @@ TODO for (R6RS BASE) div mod div-and-mod div0 mod0 div0-and-mod0 - gcd lcm + gcd lcm (don't deal with inexact ints yet) floor ceiling truncate round diff --git a/src/ikarus.boot b/src/ikarus.boot index 48bad49..e4a2bf5 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.numerics.ss b/src/ikarus.numerics.ss index c3b665e..7d81a1e 100644 --- a/src/ikarus.numerics.ss +++ b/src/ikarus.numerics.ss @@ -28,7 +28,7 @@ (library (ikarus generic-arithmetic) (export + - * / zero? = < <= > >= add1 sub1 quotient remainder - positive? expt gcd + positive? expt gcd lcm quotient+remainder number->string string->number) (import (ikarus system $fx) @@ -38,7 +38,7 @@ (ikarus system $strings) (except (ikarus) + - * / zero? = < <= > >= add1 sub1 quotient remainder quotient+remainder number->string positive? - string->number expt gcd)) + string->number expt gcd lcm)) (define (fixnum->flonum x) (foreign-call "ikrt_fixnum_to_flonum" x)) @@ -315,6 +315,38 @@ [else (f (gcd g (car ls)) (cdr ls))]))])) + (define lcm + (case-lambda + [(x y) + (cond + [(or (fixnum? x) (bignum? x)) + (cond + [(or (fixnum? y) (bignum? y)) + (let ([x (if (< x 0) (- x) x)] + [y (if (< y 0) (- y) y)]) + (let ([g (binary-gcd x y)]) + (binary* y (quotient x g))))] + [(number? y) + (error 'lcm "~s is not an exact integer" y)] + [else + (error 'lcm "~s is not a number" y)])] + [(number? x) + (error 'lcm "~s is not an exact integer" x)] + [else + (error 'lcm "~s is not a number" x)])] + [(x) + (cond + [(or (fixnum? x) (bignum? x)) x] + [(number? x) + (error 'lcm "~s is not an exact integer" x)] + [else + (error 'lcm "~s is not a number" x)])] + [() 1] + [(x y z . ls) + (let f ([g (lcm (lcm x y) z)] [ls ls]) + (cond + [(null? ls) g] + [else (f (lcm g (car ls)) (cdr ls))]))])) diff --git a/src/makefile.ss b/src/makefile.ss index e9ef50a..42aba4b 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -380,6 +380,7 @@ [string->number i r] [flonum->string i] [gcd i r] + [lcm i r] [symbol? i r symbols] [gensym? i symbols] [gensym i symbols]