0.8.21.39: implement optimization #25

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

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 5baf7d1..57e9636 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1032,9 +1032,40 @@
 ;;; bug 211e: bogus style warning from duplicated keyword argument to
 ;;; a local function.
 (handler-bind ((style-warning #'error))
-  (let ((f (compile nil '(lambda () (flet ((foo (&key y) (list y)))
-                                     (list (foo :y 1 :y 2)))))))
+  (let ((f (compile nil '(lambda ()
+                         (flet ((foo (&key y) (list y)))
+                           (list (foo :y 1 :y 2)))))))
     (assert (equal '((1)) (funcall f)))))
 
+;;; check that EQL is optimized when other argument is (OR SYMBOL FIXNUM).
+(handler-bind ((compiler-note #'error))
+  (let ((f1 (compile nil '(lambda (x1 y1) 
+                          (declare (type (or symbol fixnum) x1)
+                                   (optimize speed))
+                          (eql x1 y1))))
+       (f2 (compile nil '(lambda (x2 y2)
+                          (declare (type (or symbol fixnum) y2)
+                                   (optimize speed))
+                          (eql x2 y2)))))
+    (let ((fix (random most-positive-fixnum))
+         (sym (gensym))
+         (e-count 0))
+      (assert (funcall f1 fix fix))
+      (assert (funcall f2 fix fix))
+      (assert (funcall f1 sym sym))
+      (assert (funcall f2 sym sym))    
+      (handler-bind ((type-error (lambda (c)
+                                  (incf e-count)
+                                  (continue c))))
+       (flet ((test (f x y)
+                (with-simple-restart (continue "continue with next test")
+                  (funcall f x y)
+                  (error "fell through with (~S ~S ~S)" f x y))))
+         (test f1 "oops" 42)
+         (test f1 (1+ most-positive-fixnum) 42)
+         (test f2 42 "oops")
+         (test f2 42 (1+ most-positive-fixnum))))
+      (assert (= e-count 4)))))
+
 ;;; success
 (quit :unix-status 104)