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

* Added the rest of fl=? fl<? fl<=? fl>? fl>=?

This commit is contained in:
Abdulaziz Ghuloum 2007-06-13 11:53:52 +03:00
parent adb65c1b84
commit 88d8e198fc
3 changed files with 56 additions and 43 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.

95
src/ikarus.numerics.ss
View File

@ -100,7 +100,8 @@
(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 fl<? fl+ fl-) exact->inexact floor ceiling log fl=? fl<? fl<=? fl>?
fl>=? fl+ fl-)
(import (import
(ikarus system $fx) (ikarus system $fx)
(ikarus system $flonums) (ikarus system $flonums)
@ -114,7 +115,7 @@
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<? fl+ fl-)) fl=? fl<? fl<=? fl>? fl>=? fl+ fl-))
(define (fixnum->flonum x) (define (fixnum->flonum x)
(foreign-call "ikrt_fixnum_to_flonum" x)) (foreign-call "ikrt_fixnum_to_flonum" x))
@ -1136,47 +1137,55 @@
(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<? (define-syntax define-flcmp
(case-lambda (syntax-rules ()
[(x y) [(_ fl<? $fl<)
(if (flonum? x) (define fl<?
(if (flonum? y) (case-lambda
($fl< x y) [(x y)
(error 'fl<? "~s is not a flonum" y)) (if (flonum? x)
(error 'fl<? "~s is not a flonum" x))] (if (flonum? y)
[(x y z) ($fl< x y)
(if (flonum? x) (error 'fl<? "~s is not a flonum" y))
(if (flonum? y) (error 'fl<? "~s is not a flonum" x))]
(if (flonum? z) [(x y z)
(and ($fl< x y) ($fl< y z)) (if (flonum? x)
(error 'fl<? "~s is not a flonum" z)) (if (flonum? y)
(error 'fl<? "~s is not a flonum" y)) (if (flonum? z)
(error 'fl<? "~s is not a flonum" x))] (and ($fl< x y) ($fl< y z))
[(x) (error 'fl<? "~s is not a flonum" z))
(or (flonum? x) (error 'fl<? "~s is not a flonum" y))
(error 'fl<? "~s is not a flonum" x))] (error 'fl<? "~s is not a flonum" x))]
[(x y . rest) [(x)
(let () (or (flonum? x)
(define (loopf a ls) (error 'fl<? "~s is not a flonum" x))]
(unless (flonum? a) [(x y . rest)
(error 'fl<? "~s is not a flonum" a)) (let ()
(if (null? ls) (define (loopf a ls)
#f (unless (flonum? a)
(loopf (car ls) (cdr ls)))) (error 'fl<? "~s is not a flonum" a))
(if (flonum? x) (if (null? ls)
(if (flonum? y) #f
(if ($fl< x y) (loopf (car ls) (cdr ls))))
(let f ([x y] [y (car rest)] [ls (cdr rest)]) (if (flonum? x)
(if (flonum? y) (if (flonum? y)
(if (null? ls) (if ($fl< x y)
($fl< x y) (let f ([x y] [y (car rest)] [ls (cdr rest)])
(if ($fl< x y) (if (flonum? y)
(f y (car ls) (cdr ls)) (if (null? ls)
(loopf (car ls) (cdr ls)))) ($fl< x y)
(error 'fl<? "~s is not a flonum" y))) (if ($fl< x y)
(loopf (car rest) (cdr rest))) (f y (car ls) (cdr ls))
(error 'fl<? "~s is not a flonum" y)) (loopf (car ls) (cdr ls))))
(error 'fl<? "~s is not a flonum" x)))])) (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)))]))]))
(define-flcmp fl=? $fl=)
(define-flcmp fl<? $fl<)
(define-flcmp fl<=? $fl<=)
(define-flcmp fl>? $fl>)
(define-flcmp fl>=? $fl>=)
(define fl+ (define fl+
(case-lambda (case-lambda

4
src/makefile.ss
View File

@ -367,7 +367,11 @@
[fxlogxor i] [fxlogxor i]
[fxlogor i] [fxlogor i]
[fxlognot i] [fxlognot i]
[fl=? i rfl]
[fl<? i rfl] [fl<? i rfl]
[fl<=? i rfl]
[fl>? i rfl]
[fl>=? i rfl]
[fl+ i rfl] [fl+ i rfl]
[fl- i rfl] [fl- i rfl]
[fixnum->string i] [fixnum->string i]