X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=7a644b38833fa6c5d6ecdab41d5954e4c9e6fc72;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=fc7af0fd367a3b6ae946f43d434fbb9e77ffd5ab;hpb=25c9bfeaaf0597e37271dde31eed7037dba391e0;p=sbcl.git

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index fc7af0f..7a644b3 100644
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -265,7 +265,7 @@
     ((complex rational)
      (sb!kernel:%imagpart number))
     (float
-     (float 0 number))
+     (* 0 number))
     (t
      0)))
 
@@ -675,14 +675,67 @@
     (multiple-value-bind (res rem) (,op number divisor)
       (values (float res (if (floatp rem) rem 1.0)) rem))))
 
-(!define-float-rounding-function ffloor floor
-  "Same as FLOOR, but returns first value as a float.")
-(!define-float-rounding-function fceiling ceiling
-  "Same as CEILING, but returns first value as a float." )
-(!define-float-rounding-function ftruncate truncate
-  "Same as TRUNCATE, but returns first value as a float.")
-(!define-float-rounding-function fround round
-  "Same as ROUND, but returns first value as a float.")
+(defun ftruncate (number &optional (divisor 1))
+  #!+sb-doc
+  "Same as TRUNCATE, but returns first value as a float."
+  (macrolet ((ftruncate-float (rtype)
+	       `(let* ((float-div (coerce divisor ',rtype))
+		       (res (%unary-ftruncate (/ number float-div))))
+		  (values res
+			  (- number
+			     (* (coerce res ',rtype) float-div))))))
+    (number-dispatch ((number real) (divisor real))
+      (((foreach fixnum bignum ratio) (or fixnum bignum ratio))
+       (multiple-value-bind (q r)
+	   (truncate number divisor)
+	 (values (float q) r)))
+      (((foreach single-float double-float #!+long-float long-float)
+	(or rational single-float))
+       (if (eql divisor 1)
+	   (let ((res (%unary-ftruncate number)))
+	     (values res (- number (coerce res '(dispatch-type number)))))
+	   (ftruncate-float (dispatch-type number))))
+      #!+long-float
+      ((long-float (or single-float double-float long-float))
+       (ftruncate-float long-float))
+      #!+long-float
+      (((foreach double-float single-float) long-float)
+       (ftruncate-float long-float))
+      ((double-float (or single-float double-float))
+       (ftruncate-float double-float))
+      ((single-float double-float)
+       (ftruncate-float double-float))
+      (((foreach fixnum bignum ratio)
+	(foreach single-float double-float #!+long-float long-float))
+       (ftruncate-float (dispatch-type divisor))))))
+
+(defun ffloor (number &optional (divisor 1))
+  "Same as FLOOR, but returns first value as a float."
+  (multiple-value-bind (tru rem) (ftruncate number divisor)
+    (if (and (not (zerop rem))
+             (if (minusp divisor)
+                 (plusp number)
+                 (minusp number)))
+        (values (1- tru) (+ rem divisor))
+        (values tru rem))))
+
+(defun fceiling (number &optional (divisor 1))
+  "Same as CEILING, but returns first value as a float."
+  (multiple-value-bind (tru rem) (ftruncate number divisor)
+    (if (and (not (zerop rem))
+             (if (minusp divisor)
+                 (minusp number)
+                 (plusp number)))
+        (values (+ tru 1) (- rem divisor))
+        (values tru rem))))
+
+;;; FIXME: this probably needs treatment similar to the use of
+;;; %UNARY-FTRUNCATE for FTRUNCATE.
+(defun fround (number &optional (divisor 1))
+  "Same as ROUND, but returns first value as a float."
+  (multiple-value-bind (res rem)
+      (round number divisor)
+    (values (float res (if (floatp rem) rem 1.0)) rem)))
 
 ;;;; comparisons