0.8.11.10:

	Implement a slightly-broken %UNARY-FTRUNCATE
	... slightly broken because it doesn't distinguish between
		positive and negative zeros
	... however, it's better than before: x86/Linux is now down
		to 232 failures on ieeefp-tests 1.4
	... will fix the brokenness shortly

package-data-list.lisp-expr

@@ -1043,7 +1043,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
              "%SINGLE-FLOAT" "%SINH" 
              "%SQRT" "%SXHASH-SIMPLE-STRING"
              "%SXHASH-SIMPLE-SUBSTRING" "%TAN" "%TAN-QUICK"
-             "%TANH" "%UNARY-ROUND" "%UNARY-TRUNCATE"
+             "%TANH" "%UNARY-ROUND" "%UNARY-TRUNCATE" "%UNARY-FTRUNCATE"
              "%WITH-ARRAY-DATA" "%WITH-ARRAY-DATA-MACRO" 
              "*ALREADY-MAYBE-GCING*"
              "*CURRENT-LEVEL-IN-PRINT*" "*EMPTY-TYPE*"

src/code/float.lisp

@@ -779,6 +779,13 @@ uninterruptibly frob the rounding modes & do ieee round-to-integer.
 		 (- rounded)
 		 rounded)))))))
 
+(defun %unary-ftruncate (number)
+  (number-dispatch ((number real))
+    ((integer) (float number))
+    ((ratio) (float (truncate (numerator number) (denominator number))))
+    (((foreach single-float double-float #!+long-float long-float))
+     (%unary-ftruncate number))))
+
 (defun rational (x)
   #!+sb-doc
   "RATIONAL produces a rational number for any real numeric argument. This is

src/code/numbers.lisp

@@ -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
 

src/compiler/float-tran.lisp

@@ -1346,3 +1346,69 @@
 		    (plusp number)))
 	   (values (1+ tru) (- rem ,defaulted-divisor))
 	   (values tru rem)))))
+
+(defknown %unary-ftruncate (real) float (movable foldable flushable))
+(defknown %unary-ftruncate/single (single-float) single-float
+  (movable foldable flushable))
+(defknown %unary-ftruncate/double (double-float) double-float
+  (movable foldable flushable))
+
+(defun %unary-ftruncate/single (x)
+  (declare (type single-float x))
+  (declare (optimize speed (safety 0)))
+  (let* ((bits (single-float-bits x))
+	 (exp (ldb sb!vm:single-float-exponent-byte bits))
+	 (biased (the single-float-exponent
+		   (- exp sb!vm:single-float-bias))))
+    (declare (type (signed-byte 32) bits))
+    (cond
+      ((= exp sb!vm:single-float-normal-exponent-max) x)
+      ((<= biased 0) (* x 0f0))
+      ((>= biased (float-digits x)) x)
+      (t
+       (let ((frac-bits (- (float-digits x) biased)))
+	 (setf bits (logandc2 bits (- (ash 1 frac-bits) 1)))
+	 (make-single-float bits))))))
+
+(defun %unary-ftruncate/double (x)
+  (declare (type double-float x))
+  (declare (optimize speed (safety 0)))
+  (let* ((high (double-float-high-bits x))
+	 (low (double-float-low-bits x))
+	 (exp (ldb sb!vm:double-float-exponent-byte high))
+	 (biased (the double-float-exponent
+		   (- exp sb!vm:double-float-bias))))
+    (declare (type (signed-byte 32) high)
+	     (type (unsigned-byte 32) low))
+    (cond
+      ((= exp sb!vm:double-float-normal-exponent-max) x)
+      ((<= biased 0) (* x 0d0))
+      ((>= biased (float-digits x)) x)
+      (t
+       (let ((frac-bits (- (float-digits x) biased)))
+	 (cond ((< frac-bits 32)
+		(setf low (logandc2 low (- (ash 1 frac-bits) 1))))
+	       (t
+		(setf low 0)
+		(setf high (logandc2 high (- (ash 1 (- frac-bits 32)) 1)))))
+	 (make-double-float high low))))))
+
+(macrolet
+    ((def (float-type fun)
+	 `(deftransform %unary-ftruncate ((x) (,float-type))
+	   (let ((x-type (lvar-type x))
+		 ;; these bounds may look wrong, but in fact they're
+		 ;; right: floats within these bounds are those which
+		 ;; TRUNCATE to a (SIGNED-BYTE 32).  ROUND would be
+		 ;; different.
+		 (low-bound (coerce (- (ash 1 31)) ',float-type))
+		 (high-bound (coerce (ash 1 31) ',float-type)))
+	     (if (csubtypep x-type
+			    (specifier-type
+			     `(,',float-type (,low-bound) (,high-bound))))
+		 '(coerce (%unary-truncate x) ',float-type)
+		 `(if (< ,low-bound x ,high-bound)
+		      (coerce (%unary-truncate x) ',',float-type)
+		      (,',fun x)))))))
+  (def single-float %unary-ftruncate/single)
+  (def double-float %unary-ftruncate/double))

src/compiler/srctran.lisp

@@ -1620,6 +1620,13 @@
 		       #'%unary-truncate-derive-type-aux
 		       #'%unary-truncate))
 
+(defoptimizer (%unary-ftruncate derive-type) ((number))
+  (let ((divisor (specifier-type '(integer 1 1))))
+    (one-arg-derive-type number
+                         #'(lambda (n)
+                             (ftruncate-derive-type-quot-aux n divisor nil))
+                         #'%unary-ftruncate)))
+
 ;;; Define optimizers for FLOOR and CEILING.
 (macrolet
     ((def (name q-name r-name)

version.lisp-expr

@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.11.9"
+"0.8.11.10"