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

* libnumerics librarified

This commit is contained in:
Abdulaziz Ghuloum 2007-05-01 00:04:53 -04:00
parent 1e54a6e8da
commit 16a57eaf5c
4 changed files with 42 additions and 24 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.

53
src/libnumerics.ss
View File

@ -1,4 +1,8 @@
(library (ikarus flonums)
(export)
(import (scheme))
(let ()
(define (flonum->string x)
(or (foreign-call "ikrt_flonum_to_string" x)
@ -13,8 +17,11 @@
(lambda (x) (flonum? x)))
(primitive-set! 'flonum->string flonum->string)
(primitive-set! 'string->flonum string->flonum)
)
))
(library (ikarus flonums)
(export)
(import (scheme))
(let ()
@ -70,7 +77,7 @@
(cond
[(fixnum? x)
(cond
[(fixnum? y) (#%$fxlogand x y)]
[(fixnum? y) ($fxlogand x y)]
[(bignum? y)
(foreign-call "ikrt_fxbnlogand" x y)]
[else
@ -258,11 +265,11 @@
(define expt
(lambda (n m)
(cond
[(#%$fxzero? m) 1]
[(#%$fxzero? (#%$fxlogand m 1))
(expt (binary* n n) (#%$fxsra m 1))]
[($fxzero? m) 1]
[($fxzero? ($fxlogand m 1))
(expt (binary* n n) ($fxsra m 1))]
[else
(binary* n (expt (binary* n n) (#%$fxsra m 1)))])))
(binary* n (expt (binary* n n) ($fxsra m 1)))])))
(define max
(case-lambda
@ -626,11 +633,11 @@
(syntax-rules ()
[(_ x y cmp)
(cmp (foreign-call "ikrt_bnbncomp" x y) 0)]))
(define-syntax bnbn= (syntax-rules () [(_ x y) (bnbncmp x y #%$fx=)]))
(define-syntax bnbn< (syntax-rules () [(_ x y) (bnbncmp x y #%$fx<)]))
(define-syntax bnbn> (syntax-rules () [(_ x y) (bnbncmp x y #%$fx>)]))
(define-syntax bnbn<= (syntax-rules () [(_ x y) (bnbncmp x y #%$fx<=)]))
(define-syntax bnbn>= (syntax-rules () [(_ x y) (bnbncmp x y #%$fx>=)]))
(define-syntax bnbn= (syntax-rules () [(_ x y) (bnbncmp x y $fx=)]))
(define-syntax bnbn< (syntax-rules () [(_ x y) (bnbncmp x y $fx<)]))
(define-syntax bnbn> (syntax-rules () [(_ x y) (bnbncmp x y $fx>)]))
(define-syntax bnbn<= (syntax-rules () [(_ x y) (bnbncmp x y $fx<=)]))
(define-syntax bnbn>= (syntax-rules () [(_ x y) (bnbncmp x y $fx>=)]))
(define-syntax fxbn< (syntax-rules () [(_ x y) (positive-bignum? y)]))
(define-syntax bnfx< (syntax-rules () [(_ x y) (not (positive-bignum? x))]))
(define-syntax fxbn> (syntax-rules () [(_ x y) (not (positive-bignum? y))]))
@ -673,15 +680,15 @@
(primitive-set! '- -)
(primitive-set! '* *)
(primitive-set! '/ /)
(primitive-set! '= (mk< = #%$fx= false false bnbn=
(primitive-set! '= (mk< = $fx= false false bnbn=
fxfl= flfx= bnfl= flbn= flfl=))
(primitive-set! '< (mk< < #%$fx< fxbn< bnfx< bnbn<
(primitive-set! '< (mk< < $fx< fxbn< bnfx< bnbn<
fxfl< flfx< bnfl< flbn< flfl<))
(primitive-set! '> (mk< > #%$fx> fxbn> bnfx> bnbn>
(primitive-set! '> (mk< > $fx> fxbn> bnfx> bnbn>
fxfl> flfx> bnfl> flbn> flfl>))
(primitive-set! '<= (mk< <= #%$fx<= fxbn< bnfx< bnbn<=
(primitive-set! '<= (mk< <= $fx<= fxbn< bnfx< bnbn<=
fxfl<= flfx<= bnfl<= flbn<= flfl<=))
(primitive-set! '>= (mk< >= #%$fx>= fxbn> bnfx> bnbn>=
(primitive-set! '>= (mk< >= $fx>= fxbn> bnfx> bnbn>=
fxfl>= flfx>= bnfl>= flbn>= flfl>=))
(primitive-set! 'logand logand)
(primitive-set! 'number? number?)
@ -712,9 +719,9 @@
[(bignum? x) #f]
[(flonum? x) (= x (exact->inexact 0))]
[else (error 'zero? "tag=~s / ~s is not a number"
(#%$fxlogand 255
(#%$fxsll x 2))
(#%$fxlogand x -1)
($fxlogand 255
($fxsll x 2))
($fxlogand x -1)
)])))
(primitive-set! 'expt
@ -723,7 +730,7 @@
(error 'expt "~s is not a numebr" n))
(cond
[(fixnum? m)
(if (#%$fx>= m 0)
(if ($fx>= m 0)
(expt n m)
(error 'expt "power should be positive, got ~s" m))]
[(bignum? m)
@ -782,14 +789,14 @@
(primitive-set! 'positive?
(lambda (x)
(cond
[(fixnum? x) (#%$fx> x 0)]
[(fixnum? x) ($fx> x 0)]
[(bignum? x) (positive-bignum? x)]
[else (error 'positive? "~s is not a number" x)])))
(primitive-set! 'negative?
(lambda (x)
(cond
[(fixnum? x) (#%$fx< x 0)]
[(fixnum? x) ($fx< x 0)]
[(bignum? x) (not (positive-bignum? x))]
[else (error 'negative? "~s is not a number" x)])))
@ -836,4 +843,4 @@
(primitive-set! 'bignum?
(lambda (x) (bignum? x)))
)
))

11
src/syntax.ss
View File

@ -723,11 +723,17 @@
[* *-label (core-prim . *)]
[+ plus-label (core-prim . +)]
[number? number?-label (core-prim . number?)]
[bignum? bignum?-label (core-prim . bignum?)]
[integer? integer?-label (core-prim . integer?)]
[flonum? flonum?-label (core-prim . flonum?)]
[quotient quotient-label (core-prim . quotient)]
[remainder remainder-label (core-prim . remainder)]
[quotient+remainder quotient+remainder-label (core-prim . quotient+remainder)]
[number->string number->string-label (core-prim . number->string)]
[string->number string->number-label (core-prim . string->number)]
;;; other numerics
[flonum->string flonum->string-label (core-prim . flonum->string)]
[string->flonum string->flonum-label (core-prim . string->flonum)]
;;; symbols/gensyms
[symbol? symbol?-label (core-prim . symbol?)]
[gensym? gensym?-label (core-prim . gensym?)]
@ -2084,6 +2090,11 @@
(cons (cons lab b) r)
(cons (cons lab b) mr)
lhs* lex* rhs* kwd*)))))]
[(begin)
(syntax-match e ()
[(_ x* ...)
(f (append x* (cdr e*)) module-init**
r mr lhs* lex* rhs* kwd*)])]
[(macro)
(f (cons (add-subst rib (chi-macro value e)) (cdr e*))
module-init** r mr lhs* lex* rhs* kwd*)]