* Added flceiling, flfloor, and fixed rounding bug in flround and

round

src/ikarus.numerics.ss

@@ -10,6 +10,7 @@
           inexact->exact exact $flonum-rational? $flonum-integer? $flzero?
           $flnegative? flpositive? flabs fixnum->flonum
           flsin flcos fltan flasin flacos flatan fleven? flodd?
+          flfloor flceiling
           flinteger? flonum-bytes flnan? flfinite? flinfinite?)
   (import 
     (ikarus system $bytevectors)
@@ -19,6 +20,7 @@
             $flonum-rational? $flonum-integer?)
     (except (ikarus) inexact->exact exact flpositive? flabs fixnum->flonum
             flsin flcos fltan flasin flacos flatan fleven? flodd?
+            flfloor flceiling
             flinteger? flonum-parts flonum-bytes flnan? flfinite? flinfinite?))
   
   (define (flonum-bytes f)
@@ -227,10 +229,38 @@
     (if (flonum? x) 
         (foreign-call "ikrt_fl_atan" x)
         (error 'flatan "~s is not a flonum" x)))
+
+
+  (define (flfloor x)
+    (define (ratnum-floor x)
+      (let ([n (numerator x)] [d (denominator x)])
+        (let ([q (quotient n d)])
+          (if (>= n 0) q (- q 1)))))
+    (cond
+      [(flonum? x) 
+       (let ([e ($flonum->exact x)])
+         (cond
+           [(ratnum? e)
+            (exact->inexact (ratnum-floor e))] 
+           [else x]))]
+      [else (error 'flfloor "~s is not a flonum" x)]))
+
+  (define (flceiling x)
+    (cond
+      [(flonum? x) 
+       (let ([e ($flonum->exact x)])
+         (cond
+           [(ratnum? e)
+            (exact->inexact (ceiling e))] 
+           [else x]))]
+      [else (error 'flceiling "~s is not a flonum" x)]))
+
   )
 
 
 
+
+
 (library (ikarus generic-arithmetic)
   (export + - * / zero? = < <= > >= add1 sub1 quotient remainder
           modulo even? odd?
@@ -1796,8 +1826,8 @@
                   [else
                    (if (even? q) q (- q 1))])))))))
 
-  (define ($flround x)
+  ;(define ($flround x)
-    (foreign-call "ikrt_fl_round" x ($make-flonum)))
+  ;  (foreign-call "ikrt_fl_round" x ($make-flonum)))
 
   ;  (let ([e ($flonum->exact x)])
   ;    (cond
@@ -1807,12 +1837,20 @@
 
   (define (flround x)
     (if (flonum? x)
-        ($flround x)
+        (let ([e ($flonum->exact x)])
+           (cond
+             [(ratnum? e) (exact->inexact ($ratnum-round e))]
+             [else x]))
         (error 'flround "~s is not a flonum" x)))
 
   (define (round x)
     (cond
-      [(flonum? x) ($flround x)]
+      [(flonum? x) 
+       (let ([e (or ($flonum->exact x) 
+                    (error 'round "~s has no real value" x))])
+         (cond
+           [(ratnum? e) (exact->inexact ($ratnum-round e))]
+           [else x]))]
       [(ratnum? x) ($ratnum-round x)]
       [(or (fixnum? x) (bignum? x)) x]
       [else (error 'round "~s is not a number" x)]))

src/makefile.ss

@@ -469,13 +469,15 @@
     [flpositive?             i rfl]
     [flabs                   i rfl]
     [flmax                   i rfl]
-    [flround                 i rfl]
     [flsin                   i rfl]
     [flcos                   i rfl]
     [fltan                   i rfl]
     [flasin                  i rfl]
     [flacos                  i rfl]
     [flatan                  i rfl]
+    [flfloor                 i rfl]
+    [flround                 i rfl]
+    [flceiling               i rfl]
     [fixnum->string          i]
     [string->flonum          i]
     [-                       i r]

src/todo-r6rs.ss

@@ -312,7 +312,7 @@
     [flacos                                     C fl]
     [flasin                                     C fl]
     [flatan                                     C fl]
-    [flceiling                                  S fl]
+    [flceiling                                  C fl]
     [flcos                                      C fl]
     [fldenominator                              S fl]
     [fldiv                                      S fl]
@@ -323,7 +323,7 @@
     [flexp                                      S fl]
     [flexpt                                     S fl]
     [flfinite?                                  C fl]
-    [flfloor                                    S fl]
+    [flfloor                                    C fl]
     [flinfinite?                                C fl]
     [flinteger?                                 C fl]
     [fllog                                      S fl]