From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 30 Jun 2005 17:39:12 +0000 (+0000)
Subject: Fix flonum comparison operations that were assuming that
X-Git-Tag: 20090517-FFI~1265
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bfa418beb702d513c81c7610ad59251f8805690d;p=mit-scheme.git

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 8ff8a2b0c..148ebcbb3 100644
--- 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 7c0fab2c2..4dc85d2be 100644
--- 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)))
-
+
 (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)))
 
 ;;;; 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