0.8.10.25:

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

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 56811da..28b3242 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1181,6 +1181,84 @@
                (catch 'ct1 (throw 'ct1 0))))))
          15867134))
 
+;;; misc.361: replacing CAST with (m-v-call #'%compile-time-type-error)
+;;; could transform known-values LVAR to UVL
+(assert (zerop (funcall
+   (compile
+    nil
+    '(lambda (a b c)
+       (declare (notinline boole values denominator list))
+       (declare
+       (optimize (speed 2)
+                 (space 0)
+                 (safety 1)
+                 (debug 0)
+                 (compilation-speed 2)))
+       (catch 'ct6
+        (progv
+            '(*s8*)
+            (list 0)
+          (let ((v9 (ignore-errors (throw 'ct6 0))))
+            (denominator
+             (progv nil nil (values (boole boole-and 0 v9)))))))))
+   1 2 3)))
+
+;;; non-continuous dead UVL blocks
+(defun non-continuous-stack-test (x)
+  (multiple-value-call #'list
+    (eval '(values 11 12))
+    (eval '(values 13 14))
+    (block ext
+      (return-from non-continuous-stack-test
+        (multiple-value-call #'list
+          (eval '(values :b1 :b2))
+          (eval '(values :b3 :b4))
+          (block int
+            (return-from ext
+              (multiple-value-call (eval #'values)
+                (eval '(values 1 2))
+                (eval '(values 3 4))
+                (block ext
+                  (return-from int
+                    (multiple-value-call (eval #'values)
+                      (eval '(values :a1 :a2))
+                      (eval '(values :a3 :a4))
+                      (block int
+                        (return-from ext
+                          (multiple-value-call (eval #'values)
+                            (eval '(values 5 6))
+                            (eval '(values 7 8))
+                            (if x
+                                :ext
+                                (return-from int :int))))))))))))))))
+(assert (equal (non-continuous-stack-test t) '(11 12 13 14 1 2 3 4 5 6 7 8 :ext)))
+(assert (equal (non-continuous-stack-test nil) '(:b1 :b2 :b3 :b4 :a1 :a2 :a3 :a4 :int)))
+
+;;; MISC.362: environment of UNWIND-PROTECTor is different from that
+;;; if ENTRY.
+(assert (equal (multiple-value-list (funcall
+   (compile
+    nil
+    '(lambda (b g h)
+       (declare (optimize (speed 3) (space 3) (safety 2)
+                         (debug 2) (compilation-speed 3)))
+       (catch 'ct5
+        (unwind-protect
+            (labels ((%f15 (f15-1 f15-2 f15-3)
+                            (rational (throw 'ct5 0))))
+              (%f15 0
+                    (apply #'%f15
+                           0
+                           h
+                           (progn
+                             (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b)
+                             0)
+                           nil)
+                    0))
+          (common-lisp:handler-case 0)))))
+   1 2 3))
+ '(0)))
+
 \f
 ;;; MISC.275
 (assert
@@ -1261,3 +1339,36 @@
   (compiler-note () (error "IDENTITY derive-type not applied.")))
 
 (assert (null (funcall (compile nil '(lambda (x) (funcall #'cddr x))) nil)))
+
+;;; MISC.293 = easy variant of bug 303: repeated write to the same
+;;; LVAR; here the first write may be cleared before the second is
+;;; made.
+(assert
+ (zerop
+  (funcall
+   (compile
+    nil
+    '(lambda ()
+      (declare (notinline complex))
+      (declare (optimize (speed 1) (space 0) (safety 1)
+                (debug 3) (compilation-speed 3)))
+      (flet ((%f () (multiple-value-prog1 0 (return-from %f 0))))
+        (complex (%f) 0)))))))
+
+;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type
+(assert (zerop (funcall
+  (compile
+   nil
+   '(lambda (a c)
+     (declare (type (integer -1294746569 1640996137) a))
+     (declare (type (integer -807801310 3) c))
+     (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3)))
+     (catch 'ct7
+       (if
+        (logbitp 0
+                 (if (/= 0 a)
+                     c
+                     (ignore-errors
+                       (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7 0))) 0 0) 0))))
+        0 0))))
+   391833530 -32785211)))