0.8.4.2:

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

diff --git a/tests/compiler.pure-cload.lisp b/tests/compiler.pure-cload.lisp
index 3f913cf..85b484d 100644 (file)
--- a/tests/compiler.pure-cload.lisp
+++ b/tests/compiler.pure-cload.lisp
@@ -59,3 +59,87 @@
                              (symbol-value 'a))
                        a b)
                  '(1 2 :a 1 2))))
+
+;;; bug in LOOP, reported by ??? on c.l.l
+(flet ((foo (l)
+         (loop for x in l
+               when (symbolp x) return x
+               while (numberp x)
+               collect (list x))))
+  (assert (equal (foo '(1 2 #\a 3)) '((1) (2))))
+  (assert (equal (foo '(1 2 x 3)) 'x)))
+
+;;; compiler failure found by Paul Dietz' randomized tortuter
+(defun #:foo (a b c d)
+  (declare (type (integer 240 100434465) a)
+           (optimize (speed 3) (safety 1) (debug 1)))
+  (logxor
+   (if (ldb-test (byte 27 4) d)
+       -1
+       (max 55546856 -431))
+   (logorc2
+    (if (>= 0 b)
+        (if (> b c) (logandc2 c d) (if (> d 224002) 0 d))
+        (signum (logior c b)))
+    (logior a -1))))
+
+(defun #:foo (b c)
+  (declare (type (integer -23228343 2) b)
+          (type (integer -115581022 512244512) c)
+          (optimize (speed 3) (safety 1) (debug 1)))
+  (* (* (logorc2 3 (deposit-field 4667947 (byte 14 26) b))
+       (deposit-field b (byte 25 27) -30424886))
+     (dpb b (byte 23 29) c)))
+
+(defun #:foo (x y)
+  (declare (type (integer -1 1000000000000000000000000) x y)
+          (optimize speed))
+  (* x (* y x)))
+
+(defun #:foo (b)
+  (declare (type (integer -290488443 2) b)
+           (optimize (speed 3) (safety 1) (debug 1)))
+  (let ((v3 (min -1720 b))) (max v3 (logcount (if (= v3 b) b b)))))
+
+(defun #:foo (d)
+  (let ((v7 (flet ((%f16 () (labels ((%f3 () -8)) (%f3))))
+              (labels ((%f7 () (%f16)))  d))))
+    132887443))
+
+;;; RESULT-FORM in DO is not contained in the implicit TAGBODY
+(assert (eq (handler-case (eval `(do ((x '(1 2 3) (cdr x)))
+                                     ((endp x) (go :loop))
+                                  :loop
+                                   (unless x (return :bad))))
+              (error () :good))
+            :good))
+(assert (eq (handler-case (eval `(do* ((x '(1 2 3) (cdr x)))
+                                      ((endp x) (go :loop))
+                                  :loop
+                                   (unless x (return :bad))))
+              (error () :good))
+            :good))
+
+;;; bug 282
+;;;
+;;; Verify type checking policy in full calls: the callee is supposed
+;;; to perform check, but the results should not be used before the
+;;; check will be actually performed.
+(locally
+    (declare (optimize (safety 3)))
+  (flet ((bar (f a)
+           (declare (type (simple-array (unsigned-byte 32) (*)) a))
+           (declare (type (function (fixnum)) f))
+           (funcall f (aref a 0))))
+    (assert
+     (eval `(let ((n (1+ most-positive-fixnum)))
+              (if (not (typep n '(unsigned-byte 32)))
+                  (warn 'style-warning
+                        "~@<This test is written for platforms with ~
+                        ~@<(proper-subtypep 'fixnum '(unsigned-byte 32))~:@>.~:@>")
+                  (block nil
+                    (funcall ,#'bar
+                             (lambda (x) (when (eql x n) (return t)))
+                             (make-array 1 :element-type '(unsigned-byte 32)
+                                         :initial-element n))
+                    nil)))))))