diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 83a1e43b8..d5a9b9012 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -398,23 +398,23 @@ (sqrt number))) (defun log-double-float (number) - (if (float-sign-bit-set-p number) + (if (< number 0) (complex (log (- number)) pi) (log number))) (defun log-single-float (number) - (if (float-sign-bit-set-p number) + (if (< number 0) (complex (log (- number)) (coerce pi 'single-float)) (log number))) (defun log-double-float2 (number base) - (if (or (float-sign-bit-set-p number) + (if (or (< number 0) (< base 0)) (/ (log number) (log base)) (truly-the double-float (log number base)))) (defun log-single-float2 (number base) - (if (or (float-sign-bit-set-p number) + (if (or (< number 0) (< base 0)) (/ (log number) (log base)) (truly-the single-float (log number base)))) @@ -554,10 +554,8 @@ log2e) 'single-float))))) (((foreach single-float double-float)) - ;; Is (log -0) -infinity (libm.a) or -infinity + i*pi (Kahan)? - ;; Since this doesn't seem to be an implementation issue - ;; I (pw) take the Kahan result. - (if (float-sign-bit-set-p number) + ;; IEEE 754 says (log -0.0) should be -inf + (if (< number 0.0) (complex (log (- number)) (coerce pi '(dispatch-type number))) (coerce (%log (coerce number 'double-float)) '(dispatch-type number)))) diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 3bce5209a..3e6826813 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -501,7 +501,7 @@ (deftransform log ((x) ($type) * :node node) (let ((cast (cast-or-check-bound-type node (specifier-type 'real)))) (if cast - `(if (float-sign-bit-set-p x) + `(if (< x 0) (sb-vm::op-not-type1-error x '(,(type-specifier cast) . log)) (truly-the $type (log (truly-the (float 0.0) x)))) (give-up-ir1-transform)))) @@ -509,8 +509,7 @@ (deftransform log ((x y) ($type $type) * :node node) (let ((cast (cast-or-check-bound-type node (specifier-type 'real)))) (if cast - `(if (or (float-sign-bit-set-p x) - ;; The out of line definition returns 0 for all zeros + `(if (or (< x 0) (< y 0)) (sb-vm::op-not-type2-error x y '(,(type-specifier cast) . log)) (truly-the $type (log (truly-the (float 0.0) x) @@ -1107,15 +1106,13 @@ (defoptimizer (expt derive-type) ((x y)) (two-arg-derive-type x y #'expt-derive-type-aux)) -;;; Note we must assume that a type including 0.0 may also include -;;; -0.0 and thus the result may be complex -infinity + i*pi. (defun log-derive-type-aux-1 (x) (elfun-derive-type-simple x #'log - (if (integer-type-p x) 0 0d0) + (if (integer-type-p x) 0 -0d0) nil ;; (log 0) is an error - ;; and there's nothing between 0 and 1 forr integers. - (and (integer-type-p x) 0f0) + ;; and there's nothing between 0 and 1 for integers. + (and (integer-type-p x) -0f0) nil)) (defun log-derive-type-aux-2 (x y same-arg) diff --git a/tests/float-2.pure.lisp b/tests/float-2.pure.lisp index 4b2ed20aa..4eea251a1 100644 --- a/tests/float-2.pure.lisp +++ b/tests/float-2.pure.lisp @@ -458,17 +458,16 @@ fractional bits." (declare (double-float y)) (log y 2.0d0)) (or double-float (complex double-float))) - ;; (assert-type (lambda (d) - ;; (declare ((double-float 0d0) d)) - ;; (when (< d 1.0d0) - ;; (log d))) - ;; (or null (double-float * 0.0d0))) - ;; (assert-type (lambda (d) - ;; (declare ((double-float 0d0) d)) - ;; (when (< d 1.0d0) - ;; (log d 2.0d0))) - ;; (or null (double-float * 0.0d0))) - ) + (assert-type (lambda (d) + (declare ((double-float 0d0) d)) + (when (< d 1.0d0) + (log d))) + (or null (double-float * 0.0d0))) + (assert-type (lambda (d) + (declare ((double-float 0d0) d)) + (when (< d 1.0d0) + (log d 2.0d0))) + (or null (double-float * 0.0d0)))) (with-test (:name (ftruncate :minus-zeros :one-arg)) (flet ((f (x) (declare (notinline ftruncate)) (ftruncate x))) diff --git a/validate-float.lisp b/validate-float.lisp index f7235b9c3..e1a1a2bee 100644 --- a/validate-float.lisp +++ b/validate-float.lisp @@ -26,9 +26,7 @@ (symbol (eql x y)) (rational (eql x y)) (float (= x y)) - (string (string= x y)) - ;; KLUDGE - (complex t)))) + (string (string= x y))))) (unless (eqal actual result) (cerror "Continue" "FLOAT CACHE LINE ~S vs COMPUTED ~S~%"