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.

230
src/ikarus.numerics.ss
View File

@ -1,17 +1,73 @@
(library (ikarus numeric predicates)
(export fixnum? flonum? bignum? number? complex? real? rational?
integer? exact?)
(import
(except (ikarus) fixnum? flonum? bignum? number? complex? real?
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?
(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) (library (ikarus flonums)
(export string->flonum flonum->string flonum?) (export string->flonum flonum->string)
(import (import
(except (ikarus) flonum->string string->flonum flonum?) (except (ikarus) flonum->string string->flonum))
(rename (only (ikarus) flonum?) (flonum? sys:flonum?)))
(define flonum?
(lambda (x) (flonum? x)))
(define (flonum->string x) (define (flonum->string x)
(or (foreign-call "ikrt_flonum_to_string" x) (or (foreign-call "ikrt_flonum_to_string" x)
(error 'flonum->string "~s is not a flonum" x))) (error 'flonum->string "~s is not a flonum" x)))
(define (string->flonum x) (define (string->flonum x)
(cond (cond
[(string? x) (foreign-call "ikrt_string_to_flonum" x)] [(string? x) (foreign-call "ikrt_string_to_flonum" x)]
@ -19,13 +75,17 @@
(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?
$fxsll $fxsra $fxmodulo)
(except (ikarus) + - * = < <= > >= add1 sub1 quotient remainder
quotient+remainder number->string))
(let ()
(define (fixnum->flonum x) (define (fixnum->flonum x)
(foreign-call "ikrt_fixnum_to_flonum" x)) (foreign-call "ikrt_fixnum_to_flonum" x))
(define (bignum->flonum x) (define (bignum->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)))
)) )