conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* ikarus.numerics.ss now exports its identifiers.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-05 03:01:12 -04:00
parent 6b327d7892
commit b4659ec599
2 changed files with 125 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

224
src/ikarus.numerics.ss
View File

@ -1,12 +1,68 @@
(library (ikarus flonums)
(export string->flonum flonum->string flonum?)
(library (ikarus numeric predicates)
(export fixnum? flonum? bignum? number? complex? real? rational?
integer? exact?)
(import (import
(except (ikarus) flonum->string string->flonum flonum?) (except (ikarus) fixnum? flonum? bignum? number? complex? real?
(rename (only (ikarus) flonum?) (flonum? sys:flonum?))) rational? integer? exact?)
(rename (only (ikarus) fixnum? flonum? bignum?)
(fixnum? sys:fixnum?)
(flonum? sys:flonum?)
(bignum? sys:bignum?)))
(define fixnum?
(lambda (x) (sys:fixnum? x)))
(define bignum?
(lambda (x) (sys:bignum? x)))
(define flonum? (define flonum?
(lambda (x) (flonum? x))) (lambda (x) (sys:flonum? x)))
(define number?
(lambda (x)
(or (sys:fixnum? x)
(sys:bignum? x)
(sys:flonum? x))))
(define complex?
(lambda (x) (number? x)))
(define real?
(lambda (x) (number? x)))
(define rational?
(lambda (x)
(cond
[(sys:fixnum? x) #t]
[(sys:bignum? x) #t]
[(sys:flonum? x) #f]
[else (error 'rational? "~s is not a number" x)])))
(define integer?
(lambda (x)
(cond
[(sys:fixnum? x) #t]
[(sys:bignum? x) #t]
[(sys:flonum? x) (error 'integer "dunno for ~s" x)]
[else #f])))
(define exact?
(lambda (x)
(cond
[(sys:fixnum? x) #t]
[(sys:bignum? x) #t]
[(sys:flonum? x) #f]
[else
(error 'exact? "~s is not a number" x)]))))
(library (ikarus flonums)
(export string->flonum flonum->string)
(import
(except (ikarus) flonum->string string->flonum))
(define (flonum->string x) (define (flonum->string x)
(or (foreign-call "ikrt_flonum_to_string" x) (or (foreign-call "ikrt_flonum_to_string" x)
@ -19,12 +75,16 @@
(error 'string->flonum "~s is not a string" x)]))) (error 'string->flonum "~s is not a string" x)])))
(library (ikarus generic-arithmetic) (library (ikarus generic-arithmetic)
(export) (export + - * = < <= > >= add1 sub1 quotient remainder
(import (scheme)) quotient+remainder number->string)
(import
(only (scheme) $fxlogand $fx= $fx< $fx<= $fx> $fx>= $fxzero?
(let () $fxsll $fxsra $fxmodulo)
(except (ikarus) + - * = < <= > >= add1 sub1 quotient remainder
quotient+remainder number->string))
(define (fixnum->flonum x) (define (fixnum->flonum x)
(foreign-call "ikrt_fixnum_to_flonum" x)) (foreign-call "ikrt_fixnum_to_flonum" x))
@ -262,14 +322,6 @@
[(null? rest) (binary/ a b)] [(null? rest) (binary/ a b)]
[else (f (binary/ a b) (car ls) (cdr ls))]))])) [else (f (binary/ a b) (car ls) (cdr ls))]))]))
(define expt
(lambda (n m)
(cond
[($fxzero? m) 1]
[($fxzero? ($fxlogand m 1))
(expt (binary* n n) ($fxsra m 1))]
[else
(binary* n (expt (binary* n n) ($fxsra m 1)))])))
(define max (define max
(case-lambda (case-lambda
@ -330,44 +382,6 @@
(if (number? x) (if (number? x)
x x
(error 'min "~s is not a number" x))])) (error 'min "~s is not a number" x))]))
(define number?
(lambda (x)
(or (fixnum? x)
(bignum? x)
(flonum? x))))
(define complex?
(lambda (x) (number? x)))
(define real?
(lambda (x) (number? x)))
(define rational?
(lambda (x)
(cond
[(fixnum? x) #t]
[(bignum? x) #t]
[(flonum? x) #f]
[else (error 'rational? "~s is not a number" x)])))
(define integer?
(lambda (x)
(cond
[(fixnum? x) #t]
[(bignum? x) #t]
[(flonum? x) (error 'integer "dunno for ~s" x)]
[else #f])))
(define exact?
(lambda (x)
(cond
[(fixnum? x) #t]
[(bignum? x) #t]
[(flonum? x) #f]
[else
(error 'exact? "~s is not a number" x)])))
(define exact->inexact (define exact->inexact
(lambda (x) (lambda (x)
(cond (cond
@ -676,25 +690,25 @@
(flcmp flfl>= flfx>= fxfl>= flbn>= bnfl>= $fl>=) (flcmp flfl>= flfx>= fxfl>= flbn>= bnfl>= $fl>=)
(primitive-set! '+ +) ; (primitive-set! '+ +)
(primitive-set! '- -) ; (primitive-set! '- -)
(primitive-set! '* *) ; (primitive-set! '* *)
(primitive-set! '/ /) ; (primitive-set! '/ /)
(primitive-set! '= (mk< = $fx= false false bnbn= (define =
fxfl= flfx= bnfl= flbn= flfl=)) (mk< = $fx= false false bnbn= fxfl= flfx= bnfl= flbn= flfl=))
(primitive-set! '< (mk< < $fx< fxbn< bnfx< bnbn< (define <
fxfl< flfx< bnfl< flbn< flfl<)) (mk< < $fx< fxbn< bnfx< bnbn< fxfl< flfx< bnfl< flbn< flfl<))
(primitive-set! '> (mk< > $fx> fxbn> bnfx> bnbn> (define >
fxfl> flfx> bnfl> flbn> flfl>)) (mk< > $fx> fxbn> bnfx> bnbn> fxfl> flfx> bnfl> flbn> flfl>))
(primitive-set! '<= (mk< <= $fx<= fxbn< bnfx< bnbn<= (define <=
fxfl<= flfx<= bnfl<= flbn<= flfl<=)) (mk< <= $fx<= fxbn< bnfx< bnbn<= fxfl<= flfx<= bnfl<= flbn<= flfl<=))
(primitive-set! '>= (mk< >= $fx>= fxbn> bnfx> bnbn>= (define >=
fxfl>= flfx>= bnfl>= flbn>= flfl>=)) (mk< >= $fx>= fxbn> bnfx> bnbn>= fxfl>= flfx>= bnfl>= flbn>= flfl>=))
(primitive-set! 'logand logand) ;(primitive-set! 'logand logand)
(primitive-set! 'number? number?) ;(primitive-set! 'number? number?)
(primitive-set! 'number->string number->string) ;(primitive-set! 'number->string number->string)
(primitive-set! 'add1 (define add1
(lambda (x) (lambda (x)
(cond (cond
[(fixnum? x) [(fixnum? x)
@ -703,7 +717,7 @@
(foreign-call "ikrt_fxbnplus" 1 x)] (foreign-call "ikrt_fxbnplus" 1 x)]
[else (error 'add1 "~s is not a number" x)]))) [else (error 'add1 "~s is not a number" x)])))
(primitive-set! 'sub1 (define sub1
(lambda (x) (lambda (x)
(cond (cond
[(fixnum? x) [(fixnum? x)
@ -712,7 +726,7 @@
(foreign-call "ikrt_fxbnplus" -1 x)] (foreign-call "ikrt_fxbnplus" -1 x)]
[else (error 'sub1 "~s is not a number" x)]))) [else (error 'sub1 "~s is not a number" x)])))
(primitive-set! 'zero? (define zero?
(lambda (x) (lambda (x)
(cond (cond
[(fixnum? x) (eq? x 0)] [(fixnum? x) (eq? x 0)]
@ -724,14 +738,22 @@
($fxlogand x -1) ($fxlogand x -1)
)]))) )])))
(primitive-set! 'expt (define expt
(lambda (n m) (lambda (n m)
(define fxexpt
(lambda (n m)
(cond
[($fxzero? m) 1]
[($fxzero? ($fxlogand m 1))
(fxexpt (binary* n n) ($fxsra m 1))]
[else
(binary* n (fxexpt (binary* n n) ($fxsra m 1)))])))
(unless (number? n) (unless (number? n)
(error 'expt "~s is not a numebr" n)) (error 'expt "~s is not a numebr" n))
(cond (cond
[(fixnum? m) [(fixnum? m)
(if ($fx>= m 0) (if ($fx>= m 0)
(expt n m) (fxexpt n m)
(error 'expt "power should be positive, got ~s" m))] (error 'expt "power should be positive, got ~s" m))]
[(bignum? m) [(bignum? m)
(cond (cond
@ -749,17 +771,17 @@
(error 'expt "power should be positive, got ~s" m))])] (error 'expt "power should be positive, got ~s" m))])]
[else (error 'expt "~s is not a number" m)]))) [else (error 'expt "~s is not a number" m)])))
(primitive-set! 'quotient (define quotient
(lambda (x y) (lambda (x y)
(let-values ([(q r) (quotient+remainder x y)]) (let-values ([(q r) (quotient+remainder x y)])
q))) q)))
(primitive-set! 'remainder (define remainder
(lambda (x y) (lambda (x y)
(let-values ([(q r) (quotient+remainder x y)]) (let-values ([(q r) (quotient+remainder x y)])
r))) r)))
(primitive-set! 'quotient+remainder (define quotient+remainder
(lambda (x y) (lambda (x y)
(cond (cond
[(eq? y 0) [(eq? y 0)
@ -786,61 +808,59 @@
[else (error 'quotient+remainder [else (error 'quotient+remainder
"~s is not a number" x)]))) "~s is not a number" x)])))
(primitive-set! 'positive? (define positive?
(lambda (x) (lambda (x)
(cond (cond
[(fixnum? x) ($fx> x 0)] [(fixnum? x) ($fx> x 0)]
[(bignum? x) (positive-bignum? x)] [(bignum? x) (positive-bignum? x)]
[else (error 'positive? "~s is not a number" x)]))) [else (error 'positive? "~s is not a number" x)])))
(primitive-set! 'negative? (define negative?
(lambda (x) (lambda (x)
(cond (cond
[(fixnum? x) ($fx< x 0)] [(fixnum? x) ($fx< x 0)]
[(bignum? x) (not (positive-bignum? x))] [(bignum? x) (not (positive-bignum? x))]
[else (error 'negative? "~s is not a number" x)]))) [else (error 'negative? "~s is not a number" x)])))
(primitive-set! 'sin (define sin
(lambda (x) (lambda (x)
(cond (cond
[(flonum? x) (foreign-call "ikrt_fl_sin" x)] [(flonum? x) (foreign-call "ikrt_fl_sin" x)]
[(fixnum? x) (foreign-call "ikrt_fx_sin" x)] [(fixnum? x) (foreign-call "ikrt_fx_sin" x)]
[else (error 'sin "unsupported ~s" x)]))) [else (error 'sin "unsupported ~s" x)])))
(primitive-set! 'cos (define cos
(lambda (x) (lambda (x)
(cond (cond
[(flonum? x) (foreign-call "ikrt_fl_cos" x)] [(flonum? x) (foreign-call "ikrt_fl_cos" x)]
[(fixnum? x) (foreign-call "ikrt_fx_cos" x)] [(fixnum? x) (foreign-call "ikrt_fx_cos" x)]
[else (error 'cos "unsupported ~s" x)]))) [else (error 'cos "unsupported ~s" x)])))
(primitive-set! 'atan (define atan
(lambda (x) (lambda (x)
(cond (cond
[(flonum? x) (foreign-call "ikrt_fl_atan" x)] [(flonum? x) (foreign-call "ikrt_fl_atan" x)]
[(fixnum? x) (foreign-call "ikrt_fx_atan" x)] [(fixnum? x) (foreign-call "ikrt_fx_atan" x)]
[else (error 'atan "unsupported ~s" x)]))) [else (error 'atan "unsupported ~s" x)])))
(primitive-set! 'sqrt (define sqrt
(lambda (x) (lambda (x)
(cond (cond
[(flonum? x) (foreign-call "ikrt_fl_sqrt" x)] [(flonum? x) (foreign-call "ikrt_fl_sqrt" x)]
[(fixnum? x) (foreign-call "ikrt_fx_sqrt" x)] [(fixnum? x) (foreign-call "ikrt_fx_sqrt" x)]
[else (error 'sqrt "unsupported ~s" x)]))) [else (error 'sqrt "unsupported ~s" x)])))
(primitive-set! 'even? even?) ;(primitive-set! 'even? even?)
(primitive-set! 'odd? odd?) ;(primitive-set! 'odd? odd?)
(primitive-set! 'max max) ;(primitive-set! 'max max)
(primitive-set! 'min min) ;(primitive-set! 'min min)
(primitive-set! 'complex? complex?) ;(primitive-set! 'complex? complex?)
(primitive-set! 'real? real?) ;(primitive-set! 'real? real?)
(primitive-set! 'rational? rational?) ;(primitive-set! 'rational? rational?)
(primitive-set! 'exact? exact?) ;(primitive-set! 'exact? exact?)
(primitive-set! 'inexact? inexact?) ;(primitive-set! 'inexact? inexact?)
(primitive-set! 'integer? integer?) ;(primitive-set! 'integer? integer?)
(primitive-set! 'exact->inexact exact->inexact) ;(primitive-set! 'exact->inexact exact->inexact)
(primitive-set! 'modulo modulo) ;(primitive-set! 'modulo modulo)
(primitive-set! 'bignum?
(lambda (x) (bignum? x)))
)) )