0.8.13.41: Require robustness

[sbcl.git] / src / compiler / float-tran.lisp

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index 49b9cc7..ec1fabf 100644 (file)
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -137,10 +137,10 @@
   (values double-float-significand double-float-int-exponent (integer -1 1))
   (movable foldable flushable))
 
-(defknown scale-single-float (single-float fixnum) single-float
+(defknown scale-single-float (single-float integer) single-float
   (movable foldable flushable))
 
-(defknown scale-double-float (double-float fixnum) double-float
+(defknown scale-double-float (double-float integer) double-float
   (movable foldable flushable))
 
 (deftransform decode-float ((x) (single-float) *)
@@ -906,17 +906,21 @@
        ((csubtypep y (specifier-type 'integer))
         ;; A real raised to an integer power is well-defined.
         (merged-interval-expt x y))
+       ;; A real raised to a non-integral power can be a float or a
+       ;; complex number.
+       ((or (csubtypep x (specifier-type '(rational 0)))
+            (csubtypep x (specifier-type '(float (0d0)))))
+        ;; But a positive real to any power is well-defined.
+        (merged-interval-expt x y))
+       ((and (csubtypep x (specifier-type 'rational))
+             (csubtypep x (specifier-type 'rational)))
+        ;; A rational to the power of a rational could be a rational
+        ;; or a possibly-complex single float
+        (specifier-type '(or rational single-float (complex single-float))))
        (t
-        ;; A real raised to a non-integral power can be a float or a
-        ;; complex number.
-        (cond ((or (csubtypep x (specifier-type '(rational 0)))
-                   (csubtypep x (specifier-type '(float (0d0)))))
-               ;; But a positive real to any power is well-defined.
-               (merged-interval-expt x y))
-              (t
-               ;; a real to some power. The result could be a real
-               ;; or a complex.
-               (float-or-complex-float-type (numeric-contagion x y)))))))
+        ;; a real to some power. The result could be a real or a
+        ;; complex.
+        (float-or-complex-float-type (numeric-contagion x y)))))
 
 (defoptimizer (expt derive-type) ((x y))
   (two-arg-derive-type x y #'expt-derive-type-aux #'expt))
@@ -1342,3 +1346,56 @@
                    (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))
+           '(,fun x))))
+  (def single-float %unary-ftruncate/single)
+  (def double-float %unary-ftruncate/double))