X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=7dcc183567ab236799eb9e0a76fdfc621714807e;hb=5cf3c4259d529e180d75d4d140f344e600d2b06b;hp=0623c1f8c9ac0de54cbe1a91ee5bc580dd762700;hpb=30c93105a8bce7b701a5043fb11254f6f1bdd6da;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 0623c1f..7dcc183 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -2645,3 +2645,48 @@
                                (destructuring-bind (a (b c) d) '(1 "foo" 4)
                                  (+ a b c d)))))
                    :feh))))))
+
+;;; Functions with non-required arguments used to end up with
+;;; (&OPTIONAL-DISPATCH ...) as their names.
+(with-test (:name :hairy-function-name)
+  (assert (eq 'read-line (nth-value 2 (function-lambda-expression #'read-line))))
+  (assert (equal "#<FUNCTION READ-LINE>" (princ-to-string #'read-line))))
+
+;;; PROGV + RESTRICT-COMPILER-POLICY
+(with-test (:name :progv-and-restrict-compiler-policy)
+  (let ((sb-c::*policy-restrictions* sb-c::*policy-restrictions*))
+    (restrict-compiler-policy 'debug 3)
+    (let ((fun (compile nil '(lambda (x)
+                              (let ((i x))
+                                (declare (special i))
+                                (list i
+                                      (progv '(i) (list (+ i 1))
+                                        i)
+                                      i))))))
+      (assert (equal '(1 2 1) (funcall fun 1))))))
+
+;;; It used to be possible to confuse the compiler into
+;;; IR2-converting such a call to CONS
+(with-test (:name :late-bound-primitive)
+  (compile nil `(lambda ()
+                  (funcall 'cons 1))))
+
+(with-test (:name :hairy-array-element-type-derivation)
+  (compile nil '(lambda (x)
+                 (declare (type (and simple-string (satisfies array-has-fill-pointer-p)) x))
+                 (array-element-type x))))
+
+(with-test (:name :rest-list-type-derivation)
+  (multiple-value-bind (type derivedp)
+      (funcall (compile nil `(lambda (&rest args)
+                               (sb-c::compiler-derived-type args)))
+               nil)
+    (assert (eq 'list type))
+    (assert derivedp)))
+
+(with-test (:name :base-char-typep-elimination)
+  (assert (eq (funcall (lambda (ch)
+                         (declare (type base-char ch) (optimize (speed 3) (safety 0)))
+                         (typep ch 'base-char))
+                       t)
+              t)))