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

2
src/makefile.ss
View File

@ -243,7 +243,7 @@
["libwriter.ss" "libwriter.fasl" p0 onepass] ["libwriter.ss" "libwriter.fasl" p0 onepass]
["libtokenizer.ss" "libtokenizer.fasl" p0 onepass] ["libtokenizer.ss" "libtokenizer.fasl" p0 onepass]
["libassembler.ss" "libassembler.fasl" p0 onepass] ["libassembler.ss" "libassembler.fasl" p0 onepass]
["libintelasm.ss" "libintelasm.fasl" p0 onepass] ["libintelasm.ss" "libintelasm.fasl" p0 onepass]
["libfasl.ss" "libfasl.fasl" p0 onepass] ["libfasl.ss" "libfasl.fasl" p0 onepass]
["libtrace.ss" "libtrace.fasl" p0 onepass] ["libtrace.ss" "libtrace.fasl" p0 onepass]
["libcompile.ss" "libcompile.fasl" p1 onepass] ["libcompile.ss" "libcompile.fasl" p1 onepass]

11
src/syntax.ss
View File

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