0.9.6.32:

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

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 79c8bb7..26a5b3a 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -15,7 +15,9 @@
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
+(load "test-util.lisp")
 (load "assertoid.lisp")
+(use-package "TEST-UTIL")
 (use-package "ASSERTOID")
 
 ;;; Old CMU CL code assumed that the names of "keyword" arguments are
@@ -1067,5 +1069,103 @@
           (test f2 42 (1+ most-positive-fixnum))))
       (assert (= e-count 4)))))
 
+;;; bug #389 (Rick Taube sbcl-devel)
+(defun bes-jn (unn ux)
+   (let ((nn unn) (x ux))
+     (let* ((n (floor (abs nn)))
+            (besn
+             (if (= n 0)
+                 (bes-j0 x)
+                 (if (= n 1)
+                     (bes-j1 x)
+                     (if (zerop x)
+                         0.0
+                         (let ((iacc 40)
+                               (ans 0.0)
+                               (bigno 1.0e+10)
+                               (bigni 1.0e-10))
+                           (if (> (abs x) n)
+                               (do ((tox (/ 2.0 (abs x)))
+                                    (bjm (bes-j0 (abs x)))
+                                    (bj (bes-j1 (abs x)))
+                                    (j 1 (+ j 1))
+                                    (bjp 0.0))
+                                   ((= j n) (setf ans bj))
+                                 (setf bjp (- (* j tox bj) bjm))
+                                 (setf bjm bj)
+                                 (setf bj bjp))
+                               (let ((tox (/ 2.0 (abs x)))
+                                     (m
+                                      (* 2
+                                         (floor
+                                          (/ (+ n (sqrt (* iacc n)))
+                                             2))))
+                                     (jsum 0.0)
+                                     (bjm 0.0)
+                                     (sum 0.0)
+                                     (bjp 0.0)
+                                     (bj 1.0))
+                                 (do ((j m (- j 1)))
+                                     ((= j 0))
+                                   (setf bjm (- (* j tox bj) bjp))
+                                   (setf bjp bj)
+                                   (setf bj bjm)
+                                   (when (> (abs bj) bigno)
+                                     (setf bj (* bj bigni))
+                                     (setf bjp (* bjp bigni))
+                                     (setf ans (* ans bigni))
+                                     (setf sum (* sum bigni)))
+                                   (if (not (= 0 jsum)) (incf sum bj))
+                                   (setf jsum (- 1 jsum))
+                                   (if (= j n) (setf ans bjp)))
+                                 (setf sum (- (* 2.0 sum) bj))
+                                 (setf ans (/ ans sum))))
+                           (if (and (minusp x) (oddp n))
+                               (- ans)
+                               ans)))))))
+       (if (and (minusp nn) (oddp nn)) (- besn) besn))))
+
+
+;;; bug 233b: lvar lambda-var equality in constraint propagation
+
+;; Put this in a separate function.
+(defun test-constraint-propagation/ref ()
+  (let ((x nil))
+    (if (multiple-value-prog1 x (setq x t))
+        1
+        x)))
+
+(test-util:with-test (:name (:compiler :constraint-propagation :ref))
+  (assert (eq t (test-constraint-propagation/ref))))
+
+;; Put this in a separate function.
+(defun test-constraint-propagation/typep (x y)
+  (if (typep (multiple-value-prog1 x (setq x y))
+             'double-float)
+      (+ x 1d0)
+      (+ x 2)))
+
+(test-util:with-test (:name (:compiler :constraint-propagation :typep))
+  (assert (= 6.0d0 (test-constraint-propagation/typep 1d0 5))))
+
+(test-util:with-test (:name (:compiler :constraint-propagation :eq/eql))
+  (assert (eq :right (let ((c :wrong))
+                       (if (eq (let ((x c))
+                                 (setq c :right)
+                                 x)
+                               :wrong)
+                           c
+                           0)))))
+
+;; Put this in a separate function.
+(defun test-constraint-propagation/cast (x)
+  (when (the double-float (multiple-value-prog1
+                              x
+                            (setq x (1+ x))))
+    x))
+
+(test-util:with-test (:name (:compiler :constraint-propagation :cast))
+  (assert (assertoid:raises-error?
+           (test-constraint-propagation/cast 1) type-error)))
+
 ;;; success
-(quit :unix-status 104)