1.0.26.4: less pessimal waitqueues

[sbcl.git] / tests / float.impure.lisp

diff --git a/tests/float.impure.lisp b/tests/float.impure.lisp
index 2af31bf..aad98f5 100644 (file)
--- a/tests/float.impure.lisp
+++ b/tests/float.impure.lisp
@@ -95,5 +95,46 @@
   (test atanh)
   (test exp))
 
-;;; success
-(quit :unix-status 104)
+;;; Broken move-arg-double-float for non-rsp frame pointers on x86-64
+(defun test (y)
+  (declare (optimize speed))
+  (multiple-value-bind (x)
+      (labels ((aux (x)
+                 (declare (double-float x))
+                 (etypecase y
+                   (double-float
+                    nil)
+                   (fixnum
+                    (aux x))
+                   (complex
+                    (format t "y=~s~%" y)))
+                 (values x)))
+        (aux 2.0d0))
+    x))
+
+(assert (= (test 1.0d0) 2.0d0))
+
+(deftype myarraytype (&optional (length '*))
+  `(simple-array double-float (,length)))
+(defun new-pu-label-from-pu-labels (array)
+  (setf (aref (the myarraytype array) 0)
+        sb-ext:double-float-positive-infinity))
+
+;;; bug 407
+;;;
+;;; FIXME: it may be that TYPE-ERROR is wrong, and we should
+;;; instead signal an overflow or coerce into an infinity.
+(defun bug-407a ()
+  (loop for n from (expt 2 1024) upto (+ 10 (expt 2 1024))
+        do (handler-case
+               (coerce n 'single-float)
+             (simple-type-error ()
+               (return-from bug-407a :type-error)))))
+(assert (eq :type-error (bug-407a)))
+(defun bug-407b ()
+  (loop for n from (expt 2 1024) upto (+ 10 (expt 2 1024))
+        do (handler-case
+               (format t "~E~%" (coerce n 'single-float))
+             (simple-type-error ()
+               (return-from bug-407b :type-error)))))
+(assert (eq :type-error (bug-407b)))