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

* Added (r6rs arithmetic flonums) library containing fl<? only

This commit is contained in:
Abdulaziz Ghuloum 2007-06-13 11:37:22 +03:00
parent 352d0f54dd
commit 3fb701187e
3 changed files with 49 additions and 2 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.

47
src/ikarus.numerics.ss
View File

@ -100,7 +100,7 @@
(export + - * / zero? = < <= > >= add1 sub1 quotient remainder (export + - * / zero? = < <= > >= add1 sub1 quotient remainder
positive? expt gcd lcm numerator denominator exact-integer-sqrt positive? expt gcd lcm numerator denominator exact-integer-sqrt
quotient+remainder number->string string->number max quotient+remainder number->string string->number max
exact->inexact floor ceiling log) exact->inexact floor ceiling log fl<?)
(import (import
(ikarus system $fx) (ikarus system $fx)
(ikarus system $flonums) (ikarus system $flonums)
@ -113,7 +113,8 @@
remainder quotient+remainder number->string positive? remainder quotient+remainder number->string positive?
string->number expt gcd lcm numerator denominator string->number expt gcd lcm numerator denominator
exact->inexact floor ceiling log exact->inexact floor ceiling log
exact-integer-sqrt max)) exact-integer-sqrt max
fl<?))
(define (fixnum->flonum x) (define (fixnum->flonum x)
(foreign-call "ikrt_fixnum_to_flonum" x)) (foreign-call "ikrt_fixnum_to_flonum" x))
@ -1135,6 +1136,48 @@
(define-syntax $fl>= (define-syntax $fl>=
(syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less_or_equal" y x)])) (syntax-rules () [(_ x y) (foreign-call "ikrt_fl_less_or_equal" y x)]))
(define fl<?
(case-lambda
[(x y)
(if (flonum? x)
(if (flonum? y)
($fl< x y)
(error 'fl<? "~s is not a flonum" y))
(error 'fl<? "~s is not a flonum" x))]
[(x y z)
(if (flonum? x)
(if (flonum? y)
(if (flonum? z)
(and ($fl< x y) ($fl< y z))
(error 'fl<? "~s is not a flonum" z))
(error 'fl<? "~s is not a flonum" y))
(error 'fl<? "~s is not a flonum" x))]
[(x)
(or (flonum? x)
(error 'fl<? "~s is not a flonum" x))]
[(x y . rest)
(let ()
(define (loopf a ls)
(unless (flonum? a)
(error 'fl<? "~s is not a flonum" a))
(if (null? ls)
#f
(loopf (car ls) (cdr ls))))
(if (flonum? x)
(if (flonum? y)
(if ($fl< x y)
(let f ([x y] [y (car rest)] [ls (cdr rest)])
(if (flonum? y)
(if (null? ls)
($fl< x y)
(if ($fl< x y)
(f y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))
(error 'fl<? "~s is not a flonum" y)))
(loopf (car rest) (cdr rest)))
(error 'fl<? "~s is not a flonum" y))
(error 'fl<? "~s is not a flonum" x)))]))
(flcmp flfl= flfx= fxfl= flbn= bnfl= $fl=) (flcmp flfl= flfx= fxfl= flbn= bnfl= $fl=)
(flcmp flfl< flfx< fxfl< flbn< bnfl< $fl<) (flcmp flfl< flfx< fxfl< flbn< bnfl< $fl<)
(flcmp flfl> flfx> fxfl> flbn> bnfl> $fl>) (flcmp flfl> flfx> fxfl> flbn> bnfl> $fl>)

4
src/makefile.ss
View File

@ -117,6 +117,7 @@
[interaction (ikarus interaction) #t] [interaction (ikarus interaction) #t]
[r (r6rs) #t] [r (r6rs) #t]
[syncase (r6rs syntax-case) #t] [syncase (r6rs syntax-case) #t]
[rfl (r6rs arithmetic flonums) #t]
[mutable-pairs (r6rs mutable-pairs) #t] [mutable-pairs (r6rs mutable-pairs) #t]
[cm (chez modules) #t] [cm (chez modules) #t]
[$all (ikarus system $all) #f] [$all (ikarus system $all) #f]
@ -149,6 +150,8 @@
[interaction (ikarus interaction) #t] [interaction (ikarus interaction) #t]
[r (r6rs) #t] [r (r6rs) #t]
[syncase (r6rs syntax-case) #t] [syncase (r6rs syntax-case) #t]
[mutable-pairs (r6rs mutable-pairs) #t]
[rfl (r6rs arithmetic flonums) #t]
[cm (chez modules) #t] [cm (chez modules) #t]
[$all (ikarus system $all) #f] [$all (ikarus system $all) #f]
[$pairs (ikarus system $pairs) #f] [$pairs (ikarus system $pairs) #f]
@ -364,6 +367,7 @@
[fxlogxor i] [fxlogxor i]
[fxlogor i] [fxlogor i]
[fxlognot i] [fxlognot i]
[fl<? i rfl]
[fixnum->string i] [fixnum->string i]
[string->flonum i] [string->flonum i]
[- i r] [- i r]