1.0.9.62: Performance and stability improvement of threading on FreeBSD

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

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index a3d6f33..f91feb3 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1403,7 +1403,7 @@
 
 ;;; program-error from bad lambda-list keyword
 (assert (eq :ok
-            (handler-case 
+            (handler-case
                 (funcall (lambda (&whole x)
                            (list &whole x)))
               (program-error ()
@@ -1416,4 +1416,50 @@
               (program-error ()
                 :ok))))
 
+;;; ignore &environment
+(handler-bind ((style-warning #'error))
+  (compile nil '(lambda ()
+                 (defmacro macro-ignore-env (&environment env)
+                   (declare (ignore env))
+                   :foo)))
+  (compile nil '(lambda ()
+                 (defmacro macro-no-env ()
+                   :foo))))
+
+(dolist (*evaluator-mode* '(:interpret :compile))
+  (disassemble (eval '(defun disassemble-source-form-bug (x y z)
+                       (declare (optimize debug))
+                       (list x y z)))))
+
+;;; long-standing bug in defaulting unknown values on the x86-64,
+;;; since changing the calling convention (test case by Christopher
+;;; Laux sbcl-help 30-06-2007)
+
+(defun default-values-bug-demo-sub ()
+  (format t "test")
+  nil)
+(compile 'default-values-bug-demo-sub)
+
+(defun default-values-bug-demo-main ()
+  (multiple-value-bind (a b c d e f g h)
+      (default-values-bug-demo-sub)
+    (if a (+ a b c d e f g h) t)))
+(compile 'default-values-bug-demo-main)
+
+(assert (default-values-bug-demo-main))
+
+;;; copy propagation bug reported by Paul Khuong
+
+(defun local-copy-prop-bug-with-move-arg (x)
+  (labels ((inner ()
+             (values 1 0)))
+    (if x
+        (inner)
+        (multiple-value-bind (a b)
+            (inner)
+          (values b a)))))
+
+(assert (equal '(0 1) (multiple-value-list (local-copy-prop-bug-with-move-arg nil))))
+(assert (equal '(1 0) (multiple-value-list (local-copy-prop-bug-with-move-arg t))))
+
 ;;; success