X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ffloat.impure.lisp;h=04609a48cc23f429e17818fd3e902874f46fa90c;hb=d4d6c4b16a3655ce99a87d43f411391363531260;hp=7225011cb4c7b18554445c2718e3eda08650f3e8;hpb=ecf9476f9e868be0ee969901e075b84d7afcf9ae;p=sbcl.git

diff --git a/tests/float.impure.lisp b/tests/float.impure.lisp
index 7225011..04609a4 100644
--- a/tests/float.impure.lisp
+++ b/tests/float.impure.lisp
@@ -7,7 +7,7 @@
 ;;;; While most of SBCL is derived from the CMU CL system, the test
 ;;;; files (like this one) were written from scratch after the fork
 ;;;; from CMU CL.
-;;;; 
+;;;;
 ;;;; This software is in the public domain and is provided with
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
@@ -24,7 +24,7 @@
 ;;; e.g. someone inadvertently ports the bad code.
 (defun point39 (x y)
   (make-array 2
-	      :element-type 'double-float
+              :element-type 'double-float
               :initial-contents (list x y)))
 
 (declaim (inline point39-x point39-y))
@@ -36,23 +36,23 @@
   (aref p 1))
 (defun order39 (points)
   (sort points  (lambda (p1 p2)
-		  (let* ((y1 (point39-y p1))
-			 (y2 (point39-y p2)))
-		    (if (= y1 y2)
-			(< (point39-x p1)
-			   (point39-x p2))
-			(< y1 y2))))))
+                  (let* ((y1 (point39-y p1))
+                         (y2 (point39-y p2)))
+                    (if (= y1 y2)
+                        (< (point39-x p1)
+                           (point39-x p2))
+                        (< y1 y2))))))
 (defun test39 ()
   (order39 (make-array 4
-		       :initial-contents (list (point39 0.0d0 0.0d0)
-					       (point39 1.0d0 1.0d0)
-					       (point39 2.0d0 2.0d0)
-					       (point39 3.0d0 3.0d0)))))
+                       :initial-contents (list (point39 0.0d0 0.0d0)
+                                               (point39 1.0d0 1.0d0)
+                                               (point39 2.0d0 2.0d0)
+                                               (point39 3.0d0 3.0d0)))))
 (assert (equalp (test39)
-		#(#(0.0d0 0.0d0)
-		  #(1.0d0 1.0d0)
-		  #(2.0d0 2.0d0)
-		  #(3.0d0 3.0d0))))
+                #(#(0.0d0 0.0d0)
+                  #(1.0d0 1.0d0)
+                  #(2.0d0 2.0d0)
+                  #(3.0d0 3.0d0))))
 
 (defun complex-double-float-ppc (x y)
   (declare (type (complex double-float) x y))
@@ -68,5 +68,54 @@
 (compile 'single-float-ppc)
 (assert (= (single-float-ppc -30) -30f0))
 
-;;; success
-(quit :unix-status 104)
+;;; constant-folding irrational functions
+(declaim (inline df))
+(defun df (x)
+  ;; do not remove the ECASE here: the bug this checks for indeed
+  ;; depended on this configuration
+  (ecase x (1 least-positive-double-float)))
+(macrolet ((test (fun)
+             (let ((name (intern (format nil "TEST-CONSTANT-~A" fun))))
+               `(progn
+                  (defun ,name () (,fun (df 1)))
+                  (,name)))))
+  (test sqrt)
+  (test log)
+  (test sin)
+  (test cos)
+  (test tan)
+  (test asin)
+  (test acos)
+  (test atan)
+  (test sinh)
+  (test cosh)
+  (test tanh)
+  (test asinh)
+  (test acosh)
+  (test atanh)
+  (test exp))
+
+;;; 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))