* Added rationalize

src/ikarus.intel-assembler.ss

@@ -763,6 +763,8 @@
    [(jnle dst)   (conditional-jump #x8F dst ac)]
    [(jne dst)    (conditional-jump #x85 dst ac)]
    [(jo dst)     (conditional-jump #x80 dst ac)]
+   [(jp dst)     (conditional-jump #x8A dst ac)]
+   [(jnp dst)    (conditional-jump #x8B dst ac)]
    [(byte x)
     (unless (byte? x) (error who "~s is not a byte" x))
     (cons (byte x) ac)]

src/ikarus.numerics.ss

@@ -2307,14 +2307,67 @@
                ;;; Gee!  nans have no sign!
                "+nan.0")]
           [else (error 'flonum->string "cannot happen")]))))
-
+  ;;;
   (define (string->flonum x)
     (cond
       [(string? x)
        (foreign-call "ikrt_bytevector_to_flonum" 
          (string->utf8-bytevector x))]
       [else 
-       (error 'string->flonum "~s is not a string" x)]))
+       (error 'string->flonum "~s is not a string" x)])) )
-  
 
-  )
+(library (ikarus rationalize)
+  (export rationalize)
+  (import 
+    (except (ikarus) rationalize))
+ 
+  (define (rationalize x eps) 
+    (define who 'rationalize)
+    (define (simplest x y) 
+      (cond
+        [(< y x) (simplest y x)]
+        [(= x y) x]
+        [(> x 0)
+         (let ([n (numerator x)] [d (denominator x)]
+               [n^ (numerator y)] [d^ (denominator y)])
+           (simplest^ n d n^ d^))]
+        [(< y 0) 
+         (let ([n (numerator x)] [d (denominator x)]
+               [n^ (numerator y)] [d^ (denominator y)])
+           (- (simplest^ (- n^) d^ (- n) d)))]
+        [else 1]))
+    (define (simplest^ n d n^ d^)
+      (let-values ([(q r) (quotient+remainder n d)])
+        (if (= r 0) 
+            q
+            (let-values ([(q^ r^) (quotient+remainder n^ d^)])
+              (if (= q q^) 
+                  (let ([v (simplest^ d^ r^ d r)])
+                    (let ([n^^ (numerator v)] [d^^ (denominator v)])
+                      (/ (+ (* q n^^) d^^) n^^)))
+                  (+ q 1))))))
+    (define (go x eps)
+      (simplest (- x eps) (+ x eps)))
+    (cond
+      [(flonum? x) 
+       (if (flfinite? x)
+           (cond
+             [(flonum? eps) 
+              (if (flfinite? eps) (go x eps) +nan.0)]
+             [(or (fixnum? eps) (bignum? eps) (ratnum? eps))
+              (go x eps)]
+             [else (error who "~s is not a number" eps)])
+           (cond
+             [(flonum? eps) 
+              (if (flfinite? eps) x +nan.0)]
+             [(or (fixnum? eps) (bignum? eps) (ratnum? eps))
+              x]
+             [else (error who "~s is not a number" eps)]))]
+      [(or (fixnum? x) (bignum? x) (ratnum? x))
+       (cond
+         [(flonum? eps) 
+          (if (flfinite? eps) (go x eps) +nan.0)]
+         [(or (fixnum? eps) (bignum? eps) (ratnum? eps))
+          (go x eps)]
+         [else (error who "~s is not a number" eps)])]
+      [else (error who "~s is not a number" x)])))

src/libaltcogen.ss

@@ -2604,8 +2604,10 @@
            (cond
              [(assq x '([= !=] [!= =] [< >=] [<= >] [> <=] [>= <]
                         [u< u>=] [u<= u>] [u> u<=] [u>= u<]
-                        [fl:= fl:!=] [fl:!= fl:=] 
+                        [fl:= fl:o!=] [fl:!= fl:o=] 
-                        [fl:< fl:>=] [fl:<= fl:>] [fl:> fl:<=] [fl:>= fl:<]))
+                        [fl:< fl:o>=] [fl:<= fl:o>] 
+                        [fl:> fl:o<=] [fl:>= fl:o<]
+                        ))
               => cadr]
              [else (error who "invalid notop ~s" x)]))
          (define (jmpname x)
@@ -2613,7 +2615,10 @@
              [(assq x '([= je] [!= jne] [< jl] [<= jle] [> jg] [>= jge]
                         [u< jb] [u<= jbe] [u> ja] [u>= jae]
                         [fl:= je] [fl:!= jne]
-                        [fl:< jb] [fl:> ja] [fl:<= jbe] [fl:>= jae]))
+                        [fl:< jb] [fl:> ja] [fl:<= jbe] [fl:>= jae]
+                        [fl:o= je] [fl:o!= jne]
+                        [fl:o< jb] [fl:o> ja] [fl:o<= jbe] [fl:o>= jae]
+                        ))
               => cadr]
              [else (error who "invalid jmpname ~s" x)]))
          (define (revjmpname x)
@@ -2626,6 +2631,12 @@
            (cond
              [(memq op '(fl:= fl:!= fl:< fl:<= fl:> fl:>=))
               (cons* `(ucomisd ,(R (make-disp a0 a1)) xmm0)
+                     `(,(jmpname op) ,lab)
+                     ;;; BOGUS!
+                     ac)]
+             [(memq op '(fl:o= fl:o!= fl:o< fl:o<= fl:o> fl:o>=))
+              (cons* `(ucomisd ,(R (make-disp a0 a1)) xmm0)
+                     `(jp ,lab)
                      `(,(jmpname op) ,lab)
                      ac)]
              [(or (symbol? a0) (constant? a1))

src/makefile.ss

@@ -551,6 +551,7 @@
     [fixnum->flonum          i r]
     [exact                   i r]
     [inexact                 i r]
+    [rationalize             i]
     [random                  i]
     [symbol?                 i r symbols]
     [symbol=?                i r symbols]

src/rationalize.ss

@@ -4,46 +4,69 @@
 
       
 
+#;
 (define (rationalize x eps) 
-  (simplest (- x eps) (+ x eps)))
+  (define who 'rationalize)
-
+  (define (simplest x y) 
-
+    (cond
-(define (simplest x y) 
+      [(< y x) (simplest y x)]
+      [(= x y) x]
+      [(> x 0)
+       (let ([n (numerator x)] [d (denominator x)]
+             [n^ (numerator y)] [d^ (denominator y)])
+         (simplest^ n d n^ d^))]
+      [(< y 0) 
+       (let ([n (numerator x)] [d (denominator x)]
+             [n^ (numerator y)] [d^ (denominator y)])
+         (- (simplest^ (- n^) d^ (- n) d)))]
+      [else 1]))
+  (define (simplest^ n d n^ d^)
+    (let-values ([(q r) (quotient+remainder n d)])
+      (if (= r 0) 
+          q
+          (let-values ([(q^ r^) (quotient+remainder n^ d^)])
+            (if (= q q^) 
+                (let ([v (simplest^ d^ r^ d r)])
+                  (let ([n^^ (numerator v)] [d^^ (denominator v)])
+                    (/ (+ (* q n^^) d^^) n^^)))
+                (+ q 1))))))
+  (define (go x eps)
+    (simplest (- x eps) (+ x eps)))
   (cond
-    [(< y x) (simplest y x)]
+    [(flonum? x) 
-    [(= x y) x]
+     (if (flfinite? x)
-    [(> x 0)
+         (cond
-     (let ([n (numerator x)] [d (denominator x)]
+           [(flonum? eps) 
-           [n^ (numerator y)] [d^ (denominator y)])
+            (if (flfinite? eps) (go x eps) +nan.0)]
-       (simplest^ n d n^ d^))]
+           [(or (fixnum? eps) (bignum? eps) (ratnum? eps))
-    [(< y 0) 
+            (go x eps)]
-     (let ([n (numerator x)] [d (denominator x)]
+           [else (error who "~s is not a number" eps)])
-           [n^ (numerator y)] [d^ (denominator y)])
+         (cond
-       (- (simplest^ (- n^) d^ (- n) d)))]
+           [(flonum? eps) 
-    [else 1]))
+            (if (flfinite? eps) x +nan.0)]
+           [(or (fixnum? eps) (bignum? eps) (ratnum? eps))
+            x]
+           [else (error who "~s is not a number" eps)]))]
+    [(or (fixnum? x) (bignum? x) (ratnum? x))
+     (cond
+       [(flonum? eps) 
+        (if (flfinite? eps) (go x eps) +nan.0)]
+       [(or (fixnum? eps) (bignum? eps) (ratnum? eps))
+        (go x eps)]
+       [else (error who "~s is not a number" eps)])]
+    [else (error who "~s is not a number" x)]))
 
-(define (simplest^ n d n^ d^)
-  (let-values ([(q r) (quotient+remainder n d)])
-    (if (= r 0) 
-        q
-        (let-values ([(q^ r^) (quotient+remainder n^ d^)])
-          (if (= q q^) 
-              (let ([v (simplest^ d^ r^ d r)])
-                (let ([n^^ (numerator v)] [d^^ (denominator v)])
-                  (/ (+ (* q n^^) d^^) n^^)))
-              (+ q 1))))))
 
 (define (test v0 v1 r) 
-  (let ([s (rationalize v0 v1)])
+  (let ([s (time (rationalize v0 v1))])
-    (unless (= s r) 
+    (unless (or (= s r) (and (flnan? s) (flnan? r)))
       (error 'test "failed in ~s ~s => ~s, should be ~s" 
              v0 v1 s r))))
 
 (test 314/100 1/100 22/7)
-(test (exact 0.3) 1/10 1/3)
+(test #e0.3 1/10 1/3)
-(test 0.3 1/10 #i1/3) 
+(test 0.3 1/10 #i1/3)
-(test (/ 1.0 0.0) 3 (/ 1.0 0.0))
+(test +inf.0 3 +inf.0)
-;;; dead
+(test +inf.0 +inf.0 +nan.0)
-(test (/ 1.0 0.0) (/ 1.0 0.0) (/ (/ 0.0 0.0) (/ 1.0 0.0)))
 
 

src/todo-r6rs.ss

@@ -192,7 +192,7 @@
     [procedure?                                 C ba se]
     [rational-valued?                           S ba]
     [rational?                                  C ba se]
-    [rationalize                                S ba se]
+    [rationalize                                C ba se]
     [real-part                                  D ba se]
     [real-valued?                               S ba]
     [real?                                      C ba se]