Fix flonum comparison operations that were assuming that

    (BOOLEAN=? (NOT (FLO:< X Y)) (FLO:>= X Y))

diff --git a/v7/src/runtime/fixart.scm b/v7/src/runtime/fixart.scm
index 8ff8a2b0c5d033f45aab75f3b6f06c68e97232cb..148ebcbb39308fd4283ba392d7d670e668305e27 100644 (file)
--- a/v7/src/runtime/fixart.scm
+++ b/v7/src/runtime/fixart.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: fixart.scm,v 1.13 2003/03/03 12:42:13 cph Exp $
+$Id: fixart.scm,v 1.14 2005/06/30 17:38:33 cph Exp $
 
 Copyright 1994,1996,1999,2000,2001,2003 Massachusetts Institute of Technology
+Copyright 2005 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -117,50 +118,34 @@ USA.
   (if (not (fix:< object limit))
       (error:bad-range-argument object caller)))
 
-(define-integrable (fix:<= x y)
-  (not (fix:> x y)))
+(define-integrable (fix:<= x y) (not (fix:> x y)))
+(define-integrable (fix:>= x y) (not (fix:< x y)))
+(define-integrable (int:<= x y) (not (int:> x y)))
+(define-integrable (int:>= x y) (not (int:< x y)))
+(define (flo:<= x y) (or (flo:< x y) (flo:= x y)))
+(define (flo:>= x y) (or (flo:> x y) (flo:= x y)))
 
-(define-integrable (fix:>= x y)
-  (not (fix:< x y)))
+(define (fix:min n m) (if (fix:< n m) n m))
+(define (fix:max n m) (if (fix:> n m) n m))
 
-(define (fix:min n m)
-  (if (fix:< n m) n m))
-
-(define (fix:max n m)
-  (if (fix:> n m) n m))
-
-(define-integrable (int:<= x y)
-  (not (int:> x y)))
+(define (flo:min n m)
+  (cond ((flo:< n m) n)
+       ((flo:<= m n) m)
+       (else (error:bad-range-argument n 'FLO:MIN))))
 
-(define-integrable (int:>= x y)
-  (not (int:< x y)))
+(define (flo:max n m)
+  (cond ((flo:> n m) n)
+       ((flo:>= m n) m)
+       (else (error:bad-range-argument n 'FLO:MAX))))
 
 (define-integrable (int:->flonum n)
   ((ucode-primitive integer->flonum 2) n #b10))
 
-(define-integrable (flo:<= x y)
-  (not (flo:> x y)))
-
-(define-integrable (flo:>= x y)
-  (not (flo:< x y)))
-
-(define (flo:min n m)
-  (if (flo:< n m) n m))
-
-(define (flo:max n m)
-  (if (flo:> n m) n m))
-
 (define (->flonum x)
-  (if (not (real? x))
-      (error:wrong-type-argument x "real number" '->FLONUM))
+  (guarantee-real x '->FLONUM)
   (exact->inexact (real-part x)))
 
 (define (flo:finite? x)
-  (not (cond ((flo:> x 0.)
-             (and (flo:> x 1.)
-                  (flo:= x (flo:/ x 2.))))
-            ((flo:< x 0.)
-             (and (flo:< x -1.)
-                  (flo:= x (flo:/ x 2.))))
-            (else
-             (flo:= x 0.)))))
\ No newline at end of file
+  (if (or (flo:> x 1.) (flo:< x -1.))
+      (not (flo:= x (flo:/ x 2.)))
+      (and (flo:<= x 1.) (flo:>= x -1.))))
\ No newline at end of file

diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm
index 7c0fab2c2b67f249b6d80785d85b561ca773eeac..4dc85d2beda1965d589c7180c04e1bba37afc26b 100644 (file)
--- a/v7/src/sf/usiexp.scm
+++ b/v7/src/sf/usiexp.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: usiexp.scm,v 4.45 2005/01/06 18:10:44 cph Exp $
+$Id: usiexp.scm,v 4.46 2005/06/30 17:39:12 cph Exp $
 
 Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
 Copyright 1993,1994,1995,1997,2000,2001 Massachusetts Institute of Technology
@@ -554,7 +554,7 @@ USA.
        (constant/make (and expr (object/scode expr))
                      (string->symbol (constant/value (car operands)))))
       (if-not-expanded)))
-\f
+
 (define (intern-expansion expr operands if-expanded if-not-expanded block)
   block
   (if (and (pair? operands)
@@ -576,36 +576,6 @@ USA.
                         (ucode-primitive integer->flonum 2)
                         (list (car operands) (constant/make #f #b10))))
       (if-not-expanded)))
-
-(define (flo:<=-expansion expr operands if-expanded if-not-expanded block)
-  (if (and (pair? operands)
-          (pair? (cdr operands))
-          (null? (cddr operands)))
-      (if-expanded
-       (make-combination
-       expr
-       block
-       (ucode-primitive not)
-       (list (make-combination #f
-                               block
-                               (ucode-primitive flonum-greater?)
-                               operands))))
-      (if-not-expanded)))
-
-(define (flo:>=-expansion expr operands if-expanded if-not-expanded block)
-  (if (and (pair? operands)
-          (pair? (cdr operands))
-          (null? (cddr operands)))
-      (if-expanded
-       (make-combination
-       expr
-       block
-       (ucode-primitive not)
-       (list (make-combination #f
-                               block
-                               (ucode-primitive flonum-less?)
-                               operands))))
-      (if-not-expanded)))
 \f
 ;;;; Tables
 
@@ -665,8 +635,6 @@ USA.
     fix:<=
     fix:=
     fix:>=
-    flo:<=
-    flo:>=
     fourth
     int:->flonum
     int:integer?
@@ -748,8 +716,6 @@ USA.
    fix:<=-expansion
    fix:=-expansion
    fix:>=-expansion
-   flo:<=-expansion
-   flo:>=-expansion
    fourth-expansion
    int:->flonum-expansion
    exact-integer?-expansion