X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=d52a0dc0a1fd8e0f173fcd52db91532575438c78;hb=edf8d3701ba59bd9f0c1bd027f3179b98250cfd0;hp=9337589f49831d2055564f073f2ab5f8f75d06f0;hpb=804a4f391c8dce7d39a5339d87895b069d87554a;p=sbcl.git

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 9337589..d52a0dc 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -1264,3 +1264,28 @@ to :INTERPRET, an interpreter will be used.")
                                           bindings)))
        ,@forms)))
 
+(in-package "SB!KERNEL")
+
+(defun fp-zero-p (x)
+  (typecase x
+    (single-float (zerop x))
+    (double-float (zerop x))
+    #!+long-float
+    (long-float (zerop x))
+    (t nil)))
+
+(defun neg-fp-zero (x)
+  (etypecase x
+    (single-float
+     (if (eql x 0.0f0)
+         (make-unportable-float :single-float-negative-zero)
+         0.0f0))
+    (double-float
+     (if (eql x 0.0d0)
+         (make-unportable-float :double-float-negative-zero)
+         0.0d0))
+    #!+long-float
+    (long-float
+     (if (eql x 0.0l0)
+         (make-unportable-float :long-float-negative-zero)
+         0.0l0))))