X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=fa098af264129cab9fbc17b1d4ce356b3c3f3b58;hb=6bbc22725d3bf663726ed9adca544e39316364a6;hp=8bd3d9e0533f7b706a01edcce37c49ebac77a4dc;hpb=d984db0864aa7ba5155ec684462840ec1a49ca5b;p=sbcl.git

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 8bd3d9e..fa098af 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -15,6 +15,9 @@
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
+(when (eq sb-ext:*evaluator-mode* :interpret)
+  (sb-ext:quit :unix-status 104))
+
 (load "test-util.lisp")
 (load "assertoid.lisp")
 (use-package "TEST-UTIL")
@@ -1398,4 +1401,120 @@
   ((and (not style-warning) warning) (e)
     (error e)))
 
+;;; program-error from bad lambda-list keyword
+(assert (eq :ok
+            (handler-case
+                (funcall (lambda (&whole x)
+                           (list &whole x)))
+              (program-error ()
+                :ok))))
+(assert (eq :ok
+            (handler-case
+                (let ((*evaluator-mode* :interpret))
+                  (funcall (eval '(lambda (&whole x)
+                                   (list &whole x)))))
+              (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))))
+
+;;;; with-pinned-objects & unwind-protect, using all non-tail conventions
+
+(defun wpo-quux () (list 1 2 3))
+(defvar *wpo-quux* #'wpo-quux)
+
+(defun wpo-call ()
+  (unwind-protect
+       (sb-sys:with-pinned-objects (*wpo-quux*)
+         (values (funcall *wpo-quux*)))))
+(assert (equal '(1 2 3) (wpo-call)))
+
+(defun wpo-multiple-call ()
+  (unwind-protect
+       (sb-sys:with-pinned-objects (*wpo-quux*)
+         (funcall *wpo-quux*))))
+(assert (equal '(1 2 3) (wpo-multiple-call)))
+
+(defun wpo-call-named ()
+  (unwind-protect
+       (sb-sys:with-pinned-objects (*wpo-quux*)
+         (values (wpo-quux)))))
+(assert (equal '(1 2 3) (wpo-call-named)))
+
+(defun wpo-multiple-call-named ()
+  (unwind-protect
+       (sb-sys:with-pinned-objects (*wpo-quux*)
+         (wpo-quux))))
+(assert (equal '(1 2 3) (wpo-multiple-call-named)))
+
+(defun wpo-call-variable (&rest args)
+  (unwind-protect
+       (sb-sys:with-pinned-objects (*wpo-quux*)
+         (values (apply *wpo-quux* args)))))
+(assert (equal '(1 2 3) (wpo-call-variable)))
+
+(defun wpo-multiple-call-variable (&rest args)
+  (unwind-protect
+       (sb-sys:with-pinned-objects (*wpo-quux*)
+         (apply #'wpo-quux args))))
+(assert (equal '(1 2 3) (wpo-multiple-call-named)))
+
+(defun wpo-multiple-call-local ()
+  (flet ((quux ()
+           (wpo-quux)))
+    (unwind-protect
+         (sb-sys:with-pinned-objects (*wpo-quux*)
+           (quux)))))
+(assert (equal '(1 2 3) (wpo-multiple-call-local)))
+
+;;; bug 417: toplevel NIL confusing source path logic
+(handler-case
+    (delete-file (compile-file "bug-417.lisp"))
+  (sb-ext:code-deletion-note (e)
+    (error e)))
+
 ;;; success