[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv14977

Modified Files:
	ratios.lisp 
Log Message:
More float "emulation".


--- /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp	2007/04/08 13:44:44	1.10
+++ /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp	2008/04/17 19:35:20	1.11
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Jul 20 00:39:59 2004
 ;;;;                
-;;;; $Id: ratios.lisp,v 1.10 2007/04/08 13:44:44 ffjeld Exp $
+;;;; $Id: ratios.lisp,v 1.11 2008/04/17 19:35:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -76,10 +76,17 @@
     (integer 1)
     (ratio (%ratio-denominator x))))
 
-(defconstant least-positive-short-float 1/1000)
-(defconstant least-positive-single-float 1/1000)
-(defconstant least-positive-double-float 1/1000)
-(defconstant least-positive-long-float 1/1000)
+;;; "Floats"
+
+(defconstant most-negative-short-float most-negative-fixnum)
+(defconstant most-negative-single-float most-negative-fixnum)
+(defconstant most-negative-long-float most-negative-fixnum)
+(defconstant most-negative-double-float most-negative-fixnum)
+
+(defconstant least-positive-short-float 1/100000)
+(defconstant least-positive-single-float 1/100000)
+(defconstant least-positive-double-float 1/100000)
+(defconstant least-positive-long-float 1/100000)
 
 ;;;
 
@@ -87,6 +94,40 @@
 
 (defvar long-float-epsilon 1/10000)
 
+(defun float (x &optional proto)
+  (declare (ignore proto))
+  (check-type x float)
+  x)
+
+(defun float-radix (x)
+  (if (integerp x)
+      2
+      (denominator x)))
+
+(defun integer-decode-float (x)
+  (if (integerp x)
+      (if (minusp x)
+	  (values x 0 -1)
+	  (values x 0 1))
+      (let ((n (numerator x)))
+	(if (minusp x)
+	    (values n -1 -1)
+	    (values n -1 1)))))
+
+(defun decode-float (x)
+  (multiple-value-bind (n sign)
+      (let ((n (numerator x)))
+	(if (minusp n)
+	    (values (- n) -1)
+	    (values n 1)))
+    (let* ((r (float-radix x))
+	   (d (denominator x))
+	   (e (if (= 1 d) 0 -1)))
+      (do () ((< n 1)
+	      (values n e sign))
+	(setf n (/ n r))
+	(incf e)))))
+
 (defun cos (x)
   "http://mathworld.wolfram.com/Cosine.html"
   (do* ((rad (mod x 44/7))