X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure-cload.lisp;h=e1cba004ef00c442cfbda05431ff29c0375e9c85;hb=c58795f37078f5900aff5dc4a3712fbadd2d432e;hp=c1b5ef1b23d5c822ad67b9307b6da5b7d7cc6479;hpb=4ea1b7a6961e6b2d336603a04e448db052993244;p=sbcl.git

diff --git a/tests/compiler.pure-cload.lisp b/tests/compiler.pure-cload.lisp
index c1b5ef1..e1cba00 100644
--- a/tests/compiler.pure-cload.lisp
+++ b/tests/compiler.pure-cload.lisp
@@ -35,3 +35,52 @@
 ;;; This is a slightly different way of getting the same symptoms out
 ;;; of the sbcl-0.6.11.13 byte compiler bug.
 (print (setq *print-level* *print-level*))
+
+;;; PROGV with different numbers of variables and values
+(let ((a 1))
+  (declare (special a))
+  (assert (equal (list a (progv '(a b) '(:a :b :c)
+                           (assert (eq (symbol-value 'nil) nil))
+                           (list (symbol-value 'a) (symbol-value 'b)))
+                       a)
+                 '(1 (:a :b) 1)))
+  (assert (equal (list a (progv '(a b) '(:a :b)
+                           (assert (eq (symbol-value 'nil) nil))
+                           (list (symbol-value 'a) (symbol-value 'b)))
+                       a)
+                 '(1 (:a :b) 1)))
+  (assert (not (boundp 'b))))
+
+(let ((a 1) (b 2))
+  (declare (special a b))
+  (assert (equal (list a b (progv '(a b) '(:a)
+                             (assert (eq (symbol-value 'nil) nil))
+                             (assert (not (boundp 'b)))
+                             (symbol-value 'a))
+                       a b)
+                 '(1 2 :a 1 2))))
+
+;;; 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.
+#+nil
+(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)))))))