X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=c8d09acdded3a910c9d7a4134ae86f8f330c02f1;hb=f42877dcb11f1db580c76c37ae86541b901ac281;hp=fbadfe9e11814f2a9a60d693cf7863e087d6dada;hpb=a4ea3949e051d8c9248b231f175d54a20618743e;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index fbadfe9..c8d09ac 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -2706,9 +2706,10 @@
     (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))
+  (assert (eq (funcall (compile nil
+                                `(lambda (ch)
+                                   (declare (type base-char ch) (optimize (speed 3) (safety 0)))
+                                   (typep ch 'base-char)))
                        t)
               t)))
 
@@ -2758,7 +2759,7 @@
                           (eval '(,lambda ,@args))))))))
   (sb-vm::with-float-traps-masked
       (:divide-by-zero :overflow :inexact :invalid)
-    (let ((sb-ext:*evaluator-mode* :interpret))
+    (let (#+sb-eval (sb-ext:*evaluator-mode* :interpret))
       (declare (sb-ext:muffle-conditions style-warning))
       (test-comparison eql t t nil)
       (test-comparison eql t t t)
@@ -3681,3 +3682,108 @@
            (short-avg (/ (+ d0 d1 d2) 3)))
       (assert (and f1 f2 f3))
       (assert (< d3 (* 10 short-avg))))))
+
+(with-test (:name :bug-384892)
+  (assert (equal
+           '(function (fixnum fixnum &key (:k1 (member nil t)))
+             (values (member t) &optional))
+           (sb-kernel:%simple-fun-type
+            (compile nil `(lambda (x y &key k1)
+                            (declare (fixnum x y))
+                            (declare (boolean k1))
+                            (declare (ignore x y k1))
+                            t))))))
+
+(with-test (:name :bug-309448)
+  ;; Like all tests trying to verify that something doesn't blow up
+  ;; compile-times this is bound to be a bit brittle, but at least
+  ;; here we try to establish a decent baseline.
+  (flet ((time-it (lambda want)
+           (let* ((start (get-internal-run-time))
+                  (fun (compile nil lambda))
+                  (end (get-internal-run-time))
+                  (got (funcall fun)))
+             (unless (eql want got)
+               (error "wanted ~S, got ~S" want got))
+             (- end start))))
+    (let ((time-1/simple
+           ;; This is mostly identical as the next one, but doesn't create
+           ;; hairy unions of numeric types.
+           (time-it `(lambda ()
+                       (labels ((bar (baz bim)
+                                  (let ((n (+ baz bim)))
+                                 (* n (+ n 1) bim))))
+                      (let ((a (bar 1 1))
+                            (b (bar 1 1))
+                            (c (bar 1 1)))
+                        (- (+ a b) c))))
+                    6))
+          (time-1/hairy
+           (time-it `(lambda ()
+                       (labels ((bar (baz bim)
+                                  (let ((n (+ baz bim)))
+                                 (* n (+ n 1) bim))))
+                      (let ((a (bar 1 1))
+                            (b (bar 1 5))
+                            (c (bar 1 15)))
+                        (- (+ a b) c))))
+                    -3864)))
+      (assert (>= (* 10 (1+ time-1/simple)) time-1/hairy)))
+    (let ((time-2/simple
+           ;; This is mostly identical as the next one, but doesn't create
+           ;; hairy unions of numeric types.
+           (time-it `(lambda ()
+                       (labels ((sum-d (n)
+                                  (let ((m (truncate 999 n)))
+                                    (/ (* n m (1+ m)) 2))))
+                         (- (+ (sum-d 3)
+                               (sum-d 3))
+                            (sum-d 3))))
+                    166833))
+          (time-2/hairy
+           (time-it `(lambda ()
+                       (labels ((sum-d (n)
+                                  (let ((m (truncate 999 n)))
+                                    (/ (* n m (1+ m)) 2))))
+                         (- (+ (sum-d 3)
+                               (sum-d 5))
+                            (sum-d 15))))
+                    233168)))
+      (assert (>= (* 10 (1+ time-2/simple)) time-2/hairy)))))
+
+(with-test (:name :regression-1.0.44.34)
+  (compile nil '(lambda (z &rest args)
+                 (declare (dynamic-extent args))
+                 (flet ((foo (w v) (list v w)))
+                   (setq z 0)
+                   (flet ((foo ()
+                            (foo z args)))
+                     (declare (sb-int:truly-dynamic-extent #'foo))
+                     (call #'foo nil))))))
+
+(with-test (:name :bug-713626)
+  (let ((f (eval '(constantly 42))))
+    (handler-bind ((warning #'error))
+      (assert (= 42 (funcall (compile nil `(lambda () (funcall ,f 1 2 3)))))))))
+
+(with-test (:name :known-fun-allows-other-keys)
+  (handler-bind ((warning #'error))
+    (funcall (compile nil '(lambda () (directory "." :allow-other-keys t))))
+    (funcall (compile nil `(lambda () (directory "." :bar t :allow-other-keys t))))))
+
+(with-test (:name :bug-551227)
+  ;; This function causes constraint analysis to perform a
+  ;; ref-substitution that alters the A referred to in (G A) at in the
+  ;; consequent of the IF to refer to be NUMBER, from the
+  ;; LET-converted inline-expansion of MOD.  This leads to attempting
+  ;; to CLOSE-OVER a variable that simply isn't in scope when it is
+  ;; referenced.
+  (compile nil '(lambda (a)
+                  (if (let ((s a))
+                        (block :block
+                          (map nil
+                               (lambda (e)
+                                 (return-from :block
+                                   (f (mod a e))))
+                               s)))
+                      (g a)))))